packages feed

ghc-mod 5.1.0.2 → 5.8.0.0

raw patch · 250 files changed

Files

+ COPYING.AGPL3 view
@@ -0,0 +1,661 @@+                    GNU AFFERO GENERAL PUBLIC LICENSE+                       Version 3, 19 November 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++                            Preamble++  The GNU Affero General Public License is a free, copyleft license for+software and other kinds of works, specifically designed to ensure+cooperation with the community in the case of network server software.++  The licenses for most software and other practical works are designed+to take away your freedom to share and change the works.  By contrast,+our General Public Licenses are intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users.++  When we speak of free software, we are referring to freedom, not+price.  Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), that you receive source code or can get it if you+want it, that you can change the software or use pieces of it in new+free programs, and that you know you can do these things.++  Developers that use our General Public Licenses protect your rights+with two steps: (1) assert copyright on the software, and (2) offer+you this License which gives you legal permission to copy, distribute+and/or modify the software.++  A secondary benefit of defending all users' freedom is that+improvements made in alternate versions of the program, if they+receive widespread use, become available for other developers to+incorporate.  Many developers of free software are heartened and+encouraged by the resulting cooperation.  However, in the case of+software used on network servers, this result may fail to come about.+The GNU General Public License permits making a modified version and+letting the public access it on a server without ever releasing its+source code to the public.++  The GNU Affero General Public License is designed specifically to+ensure that, in such cases, the modified source code becomes available+to the community.  It requires the operator of a network server to+provide the source code of the modified version running there to the+users of that server.  Therefore, public use of a modified version, on+a publicly accessible server, gives the public access to the source+code of the modified version.++  An older license, called the Affero General Public License and+published by Affero, was designed to accomplish similar goals.  This is+a different license, not a version of the Affero GPL, but Affero has+released a new version of the Affero GPL which permits relicensing under+this license.++  The precise terms and conditions for copying, distribution and+modification follow.++                       TERMS AND CONDITIONS++  0. Definitions.++  "This License" refers to version 3 of the GNU Affero General Public License.++  "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++  "The Program" refers to any copyrightable work licensed under this+License.  Each licensee is addressed as "you".  "Licensees" and+"recipients" may be individuals or organizations.++  To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy.  The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++  A "covered work" means either the unmodified Program or a work based+on the Program.++  To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy.  Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++  To "convey" a work means any kind of propagation that enables other+parties to make or receive copies.  Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++  An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License.  If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++  1. Source Code.++  The "source code" for a work means the preferred form of the work+for making modifications to it.  "Object code" means any non-source+form of a work.++  A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++  The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form.  A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++  The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities.  However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work.  For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++  The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++  The Corresponding Source for a work in source code form is that+same work.++  2. Basic Permissions.++  All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met.  This License explicitly affirms your unlimited+permission to run the unmodified Program.  The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work.  This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++  You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force.  You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright.  Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++  Conveying under any other circumstances is permitted solely under+the conditions stated below.  Sublicensing is not allowed; section 10+makes it unnecessary.++  3. Protecting Users' Legal Rights From Anti-Circumvention Law.++  No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++  When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++  4. Conveying Verbatim Copies.++  You may convey verbatim copies of the Program's source code as you+receive it, in any medium, provided that you conspicuously and+appropriately publish on each copy an appropriate copyright notice;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++  You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++  5. Conveying Modified Source Versions.++  You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++    a) The work must carry prominent notices stating that you modified+    it, and giving a relevant date.++    b) The work must carry prominent notices stating that it is+    released under this License and any conditions added under section+    7.  This requirement modifies the requirement in section 4 to+    "keep intact all notices".++    c) You must license the entire work, as a whole, under this+    License to anyone who comes into possession of a copy.  This+    License will therefore apply, along with any applicable section 7+    additional terms, to the whole of the work, and all its parts,+    regardless of how they are packaged.  This License gives no+    permission to license the work in any other way, but it does not+    invalidate such permission if you have separately received it.++    d) If the work has interactive user interfaces, each must display+    Appropriate Legal Notices; however, if the Program has interactive+    interfaces that do not display Appropriate Legal Notices, your+    work need not make them do so.++  A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit.  Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++  6. Conveying Non-Source Forms.++  You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++    a) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by the+    Corresponding Source fixed on a durable physical medium+    customarily used for software interchange.++    b) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by a+    written offer, valid for at least three years and valid for as+    long as you offer spare parts or customer support for that product+    model, to give anyone who possesses the object code either (1) a+    copy of the Corresponding Source for all the software in the+    product that is covered by this License, on a durable physical+    medium customarily used for software interchange, for a price no+    more than your reasonable cost of physically performing this+    conveying of source, or (2) access to copy the+    Corresponding Source from a network server at no charge.++    c) Convey individual copies of the object code with a copy of the+    written offer to provide the Corresponding Source.  This+    alternative is allowed only occasionally and noncommercially, and+    only if you received the object code with such an offer, in accord+    with subsection 6b.++    d) Convey the object code by offering access from a designated+    place (gratis or for a charge), and offer equivalent access to the+    Corresponding Source in the same way through the same place at no+    further charge.  You need not require recipients to copy the+    Corresponding Source along with the object code.  If the place to+    copy the object code is a network server, the Corresponding Source+    may be on a different server (operated by you or a third party)+    that supports equivalent copying facilities, provided you maintain+    clear directions next to the object code saying where to find the+    Corresponding Source.  Regardless of what server hosts the+    Corresponding Source, you remain obligated to ensure that it is+    available for as long as needed to satisfy these requirements.++    e) Convey the object code using peer-to-peer transmission, provided+    you inform other peers where the object code and Corresponding+    Source of the work are being offered to the general public at no+    charge under subsection 6d.++  A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++  A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling.  In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage.  For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product.  A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++  "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source.  The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++  If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information.  But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++  The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed.  Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++  Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++  7. Additional Terms.++  "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law.  If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++  When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it.  (Additional permissions may be written to require their own+removal in certain cases when you modify the work.)  You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++  Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++    a) Disclaiming warranty or limiting liability differently from the+    terms of sections 15 and 16 of this License; or++    b) Requiring preservation of specified reasonable legal notices or+    author attributions in that material or in the Appropriate Legal+    Notices displayed by works containing it; or++    c) Prohibiting misrepresentation of the origin of that material, or+    requiring that modified versions of such material be marked in+    reasonable ways as different from the original version; or++    d) Limiting the use for publicity purposes of names of licensors or+    authors of the material; or++    e) Declining to grant rights under trademark law for use of some+    trade names, trademarks, or service marks; or++    f) Requiring indemnification of licensors and authors of that+    material by anyone who conveys the material (or modified versions of+    it) with contractual assumptions of liability to the recipient, for+    any liability that these contractual assumptions directly impose on+    those licensors and authors.++  All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10.  If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term.  If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++  If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++  Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++  8. Termination.++  You may not propagate or modify a covered work except as expressly+provided under this License.  Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++  However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++  Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++  Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License.  If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++  9. Acceptance Not Required for Having Copies.++  You are not required to accept this License in order to receive or+run a copy of the Program.  Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance.  However,+nothing other than this License grants you permission to propagate or+modify any covered work.  These actions infringe copyright if you do+not accept this License.  Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++  10. Automatic Licensing of Downstream Recipients.++  Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License.  You are not responsible+for enforcing compliance by third parties with this License.++  An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations.  If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++  You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License.  For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++  11. Patents.++  A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based.  The+work thus licensed is called the contributor's "contributor version".++  A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version.  For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++  Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++  In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement).  To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++  If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients.  "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++  If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++  A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License.  You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++  Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++  12. No Surrender of Others' Freedom.++  If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License.  If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all.  For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++  13. Remote Network Interaction; Use with the GNU General Public License.++  Notwithstanding any other provision of this License, if you modify the+Program, your modified version must prominently offer all users+interacting with it remotely through a computer network (if your version+supports such interaction) an opportunity to receive the Corresponding+Source of your version by providing access to the Corresponding Source+from a network server at no charge, through some standard or customary+means of facilitating copying of software.  This Corresponding Source+shall include the Corresponding Source for any work covered by version 3+of the GNU General Public License that is incorporated pursuant to the+following paragraph.++  Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU General Public License into a single+combined work, and to convey the resulting work.  The terms of this+License will continue to apply to the part which is the covered work,+but the work with which it is combined will remain governed by version+3 of the GNU General Public License.++  14. Revised Versions of this License.++  The Free Software Foundation may publish revised and/or new versions of+the GNU Affero General Public License from time to time.  Such new versions+will be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++  Each version is given a distinguishing version number.  If the+Program specifies that a certain numbered version of the GNU Affero General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation.  If the Program does not specify a version number of the+GNU Affero General Public License, you may choose any version ever published+by the Free Software Foundation.++  If the Program specifies that a proxy can decide which future+versions of the GNU Affero General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++  Later license versions may give you additional or different+permissions.  However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++  15. Disclaimer of Warranty.++  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++  16. Limitation of Liability.++  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++  17. Interpretation of Sections 15 and 16.++  If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++                     END OF TERMS AND CONDITIONS++            How to Apply These Terms to Your New Programs++  If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++  To do so, attach the following notices to the program.  It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    This program is free software: you can redistribute it and/or modify+    it under the terms of the GNU Affero General Public License as published by+    the Free Software Foundation, either version 3 of the License, or+    (at your option) any later version.++    This program is distributed in the hope that it will be useful,+    but WITHOUT ANY WARRANTY; without even the implied warranty of+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+    GNU Affero General Public License for more details.++    You should have received a copy of the GNU Affero General Public License+    along with this program.  If not, see <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++  If your software can interact with users remotely through a computer+network, you should also make sure that it provides a way for users to+get its source.  For example, if your program is a web application, its+interface could display a "Source" link that leads users to an archive+of the code.  There are many ways you could offer source, and different+solutions will be better for different programs; see section 13 for the+specific requirements.++  You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU AGPL, see+<http://www.gnu.org/licenses/>.
+ COPYING.BSD3 view
@@ -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.
ChangeLog view
@@ -1,33 +1,144 @@+2017-05-26 v5.8.0.0+	* Fix logic bug in fix for excessive use of `map-file`+	* Bump HLint to 2.x+	* Reorganize Cabal file to make maintanance easier+	* Merge #872, Do not log warning when Stack project is preferred+	* Merge #873, Fix build on case-insensitive filesystems+	* Fix 'debug' command when ghc(-pkg) not on PATH+	* Rework README+	* Reorganize modules as preparation for splitting off ghc-mod-core+	* Remove dependency on 'pretty' and use GHC's pretty printer instead+	* Merge #854, Fix for "ghc-mod doc" when usind with stack+	* Merge #858, Fix Gap.fromTyThing returning GHC internal+	  representation instead of the user readable representation of+	  types+	* Fix #774, 'find*File' searching all the way up to /+	* Fix #778, Check directory permissions before reading in+	  findFileInParentsP+	* Merge #817, fix #779, bad "ghc-mod check" performance++2017-01-16 v5.7.0.0+	* Bump cabal-helper to 0.7.3.0 to support Cabal-1.24.1.0+	* Bump haskell-src-exts, optparse-applicative, pipes and extra+	  to be compatible with stackage.++2016-07-29 v5.6.0.0+	* Bump cabal-helper to 0.7, adds support for Cabal-1.24+	* Merge #737, `map-file` caching issues+	* Merge #767, Add `browse` option to show symbol "parents"+	* Merge #731, Type constraints+	* Fix #69 (via #731), Missing type constraints+	* Fix #438, Case splitting not working+	* Fix #790, Don't try to use 'cabal' or 'stack' when it's not installed+	* Add support for GHC 8.0++2016-01-19 v5.5.0.0+	* Fix #660, cabal-helper errors when no global GHC is installed (Stack)+	* Fix #665, Reinstate internally managed CWD (no more `ghc-mod root`+	  requirement for frontends)+	* Merge #707, Support for spaces in file names when using+	  legacy-interactive+	* Merge #694, #706, #703, Rewrite command line parser using+	  optparse-applicative. Thanks @lierdakil!+	* Merge #693, Fix slowdown and bugs caused by excessive use of+	  `map-file`+	* Fix #678, "No instance nor default method for class operation put"+	* Fix #683, #684, a variety of caching related issues+	* Fix #666, The issue of the beast >:3+	* Merge #649, elisp: Add ghc-report-errors to inhibit *GHC Error*+	  logging+	* Fix #621, Preserve Cabal flag selection across automatic+	  reconfiguration++2015-09-16 v5.4.0.0+	* Add support for the Stack build tool+	* Fix #554, `module not interpreted` errors when using the `type`+	  command+	* Merge #484, support for file redirection+	* Add support for file redirection to Emacs frontend so+	  all commands should work even with unsaved files now!+	* Support inserting holes in type signatures+	* Merge #543, Fix URL anchors being dropped in OS X+	* Fix GHC session always being dropped in interactive mode (caused+	  super slowness)+	* Expose all internal modules because API will get a major+	  redesign soon anyways+	* ghc-mod(i) executable must now be run in project directory for+	  commands other than `root`+	* Add --line-prefix option for multiplexing stdout/err onto one stream++2015-08-14 v5.3.0.0+	* Re-license majority of code under the AGPL-3+	* Add support for GHC 7.10 and Cabal 1.22+	* Remove `cabalDependPackages', `cabalAllTargets'+	* Merge #434, Fix finding sandbox config file and directory.+	* Merge #431, Re-add output line separator global option for expand+	  command.+	* Merge #470, Support for overriding the package-db stack+	* Merge #486, Fix ineffective cache invalidation for `find`++2014-12-31 v5.2.1.2+	* Merge #377, Fix `browse` erroneously thinking haskell2010 identifiers+	  are operators+	* Fix incompatibility with monad-control >= 1.0.0+	* Fix temporary directories not being removed properly+	* Merge #405, #408, a race condition in the Emacs frontend+	* Merge #403, Support unicode quotes in module regexp++2014-11-03 v5.2.1.1+	* Fix `findCabalFiles` thinking `$HOME/.cabal` is a cabal file.+	* Support `where` clauses, `let` bindings and `case` expressions+	  in case splitting, #400++2014-11-02 v5.2.1.0+	* Fix `newTempDir` on Windows+	* GhcModT's liftIO instance now converts GhcMOdError exceptions+	  into monadic failures++2014-10-30 v5.2.0.0+	* Return type of `loadSymbolDb` is now in GhcModT+	* Function `dumpSymbol` now takes the path of the target directory+	* Fix #387, Pattern match failure in GhcPkg+	* Fix #386, `ghc-mod version` should not check `cabal configure`+	* Fix #391, Error on command `-g` when used before command despite+	  --help output saying this is valid+	* Fix formatting of `ghc-version` constant in the elisp code.  in+	  version 5.1.1.0 the string was "v5.1.1.0" instead of "5.1.1.0".++2014-10-04 v5.1.1.0+	* Handle various consistency related issues: #222, #224, #326, #332+	* Add `isOutdated` to Language.Haskell.GhcMod+ 2014-09-17 v5.1.0.2-        * Fix building with haskell-src-exts < 1.16.0+	* Fix building with haskell-src-exts < 1.16.0  2014-09-16 v5.1.0.1-        * Fix building with haskell-src-exts-1.16.0-        * Loosen monad-journal dependency+	* Fix building with haskell-src-exts-1.16.0+	* Loosen monad-journal dependency  2014-09-12 v5.1.0.0-        * GhcModError is now a recursive data type (`GMECabalConfigure`'s-          type changed)-        * GhcModT's MonadIO instance now converts IOError's to failures in-          the ErrorT part of GhcModT on `liftIO`.-        * Make `loadSymbolDb` polimorphic in the return types's monad.-        * Add `hoistGhcModT` to Language.Haskell.GhcMod.Internal-        * Fix `check` command for modules using `-XPatternSynonyms`-        * Merge #364, Support cabal configuration flags+	* GhcModError is now a recursive data type (`GMECabalConfigure`'s+	  type changed)+	* GhcModT's MonadIO instance now converts IOError's to failures in+	  the ErrorT part of GhcModT on `liftIO`.+	* Make `loadSymbolDb` polimorphic in the return types's monad.+	* Add `hoistGhcModT` to Language.Haskell.GhcMod.Internal+	* Fix `check` command for modules using `-XPatternSynonyms`+	* Merge #364, Support cabal configuration flags  2014-08-29 v5.0.1.2-        * Merge #345, Try fixing duplicate errors-        * Merge #344, elisp: Use advice to check syntax on save-buffer-        * Merge #341, support `browse -d` in ghc-modi-        * Merge #352, elisp: Fix C-u accidentally getting turned into a-          prefix command+	* Merge #345, Try fixing duplicate errors+	* Merge #344, elisp: Use advice to check syntax on save-buffer+	* Merge #341, support `browse -d` in ghc-modi+	* Merge #352, elisp: Fix C-u accidentally getting turned into a+	  prefix command  2014-08-24 v5.0.1.1-        * Fix CaseSplitting faliure when using "fancy types" (see #336)-        * Print error information in "spec" test suite when using `extract`+	* Fix CaseSplitting faliure when using "fancy types" (see #336)+	* Print error information in "spec" test suite when using `extract`  2014-08-20 v5.0.1-        * Fix missing file in "Data-Files"+	* Fix missing file in "Data-Files"  2014-08-20 v5.0.0 	* ghc-mod consumes much less memory than ghc-mod-4.1.
+ GhcMod.hs view
@@ -0,0 +1,92 @@+-- | The ghc-mod library.++module GhcMod (+  -- * Cradle+    Cradle(..)+  , Project(..)+  , findCradle+  -- * Options+  , Options(..)+  , LineSeparator(..)+  , OutputStyle(..)+  , FileMapping(..)+  , defaultOptions+  -- * Logging+  , GmLogLevel+  , increaseLogLevel+  , decreaseLogLevel+  , gmSetLogLevel+  , gmLog+  -- * Types+  , ModuleString+  , Expression(..)+  , GhcPkgDb+  , Symbol+  , SymbolDb+  , GhcModError(..)+  -- * Monad Types+  , GhcModT+  , IOish+  -- * Monad utilities+  , runGhcModT+  , withOptions+  , dropSession+  -- * 'GhcMod' utilities+  , boot+  , browse+  , check+  , checkSyntax+  , debugInfo+  , componentInfo+  , expandTemplate+  , info+  , lint+  , pkgDoc+  , rootInfo+  , types+  , test+  , splits+  , sig+  , refine+  , auto+  , modules+  , languages+  , flags+  , findSymbol+  , lookupSymbol+  , dumpSymbol+  -- * SymbolDb+  , loadSymbolDb+  , isOutdated+  -- * Output+  , gmPutStr+  , gmErrStr+  , gmPutStrLn+  , gmErrStrLn+  -- * FileMapping+  , loadMappedFile+  , loadMappedFileSource+  , unloadMappedFile+  ) where++import GhcMod.Exe.Boot+import GhcMod.Exe.Browse+import GhcMod.Exe.CaseSplit+import GhcMod.Exe.Check+import GhcMod.Exe.Debug+import GhcMod.Exe.FillSig+import GhcMod.Exe.Find+import GhcMod.Exe.Flag+import GhcMod.Exe.Info+import GhcMod.Exe.Lang+import GhcMod.Exe.Lint+import GhcMod.Exe.Modules+import GhcMod.Exe.PkgDoc+import GhcMod.Exe.Test+import GhcMod.Cradle+import GhcMod.FileMapping+import GhcMod.Logging+import GhcMod.Monad+import GhcMod.Output+import GhcMod.Target+import GhcMod.Types
+ GhcMod/Exe/Boot.hs view
@@ -0,0 +1,29 @@+module GhcMod.Exe.Boot where++import Control.Applicative+import Prelude++import GhcMod.Exe.Browse+import GhcMod.Exe.Flag+import GhcMod.Exe.Lang+import GhcMod.Exe.Modules+import GhcMod.Monad+import GhcMod.Types (defaultBrowseOpts)++-- | Printing necessary information for front-end booting.+boot :: IOish m => GhcModT m String+boot = concat <$> sequence ms+  where+    ms = [modules False, languages, flags, concat <$> mapM (browse defaultBrowseOpts) preBrowsedModules]++preBrowsedModules :: [String]+preBrowsedModules = [+    "Prelude"+  , "Control.Applicative"+  , "Control.Exception"+  , "Control.Monad"+  , "Data.Char"+  , "Data.List"+  , "Data.Maybe"+  , "System.IO"+  ]
+ GhcMod/Exe/Browse.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE CPP #-}+module GhcMod.Exe.Browse (+    browse,+    BrowseOpts(..)+  ) where++import Safe+import Control.Applicative+import Control.Exception (SomeException(..))+import Data.Char+import Data.List+import Data.Maybe+import FastString+import GHC+import HscTypes+import qualified GHC as G+import GhcMod.Convert+import GhcMod.Doc (showPage, styleUnqualified)+import GhcMod.Gap as Gap+import GhcMod.Types+import GhcMod.Monad+import GhcMod.Logging+import Name (getOccString)+import Outputable+import TyCon (isAlgTyCon)+import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy)+import Exception (ExceptionMonad, ghandle)+import Prelude+#if __GLASGOW_HASKELL__ >= 800+import PatSyn (pprPatSynType)+#endif++----------------------------------------------------------------++-- | Getting functions, classes, etc from a module.+browse :: forall m. IOish m+           => BrowseOpts -- ^ Configuration parameters+           -> String -- ^ A module name. (e.g. \"Data.List\", "base:Prelude")+           -> GhcModT m String+browse opts pkgmdl = do+    convert' . sort =<< go+  where+    -- TODO: Add API to Gm.Target to check if module is home module without+    -- bringing up a GHC session as well then this can be made a lot cleaner+    go = ghandle (\ex@(SomeException _) -> logException ex >> return []) $ do+      goPkgModule `G.gcatch` (\(SomeException _) -> goHomeModule)++    logException ex =+        gmLog GmException "browse" $ showToDoc ex++    goPkgModule = do+      runGmPkgGhc $+        processExports opts =<< tryModuleInfo =<< G.findModule mdlname mpkgid++    goHomeModule = runGmlT [Right mdlname] $ do+      processExports opts =<< tryModuleInfo =<< G.findModule mdlname Nothing++    tryModuleInfo m = fromJustNote "browse, tryModuleInfo" <$> G.getModuleInfo m++    (mpkg, mdl) = splitPkgMdl pkgmdl+    mdlname = G.mkModuleName mdl+    mpkgid = mkFastString <$> mpkg++-- |+--+-- >>> splitPkgMdl "base:Prelude"+-- (Just "base","Prelude")+-- >>> splitPkgMdl "Prelude"+-- (Nothing,"Prelude")+splitPkgMdl :: String -> (Maybe String,String)+splitPkgMdl pkgmdl =+  case break (==':') pkgmdl of+    (mdl, "")    -> (Nothing, mdl)+    (pkg, _:mdl) -> (Just pkg, mdl)++-- Haskell 2010:+-- small -> ascSmall | uniSmall | _+-- ascSmall -> a | b | ... | z+-- uniSmall -> any Unicode lowercase letter+-- varid -> (small {small | large | digit | ' })++isNotOp :: String -> Bool+isNotOp (h:_) = isAlpha h || (h == '_')+isNotOp _ = error "isNotOp"++processExports :: (G.GhcMonad m, MonadIO m, ExceptionMonad m)+               => BrowseOpts -> ModuleInfo -> m [String]+processExports opt minfo = do+  let+    removeOps+      | optBrowseOperators opt = id+      | otherwise = filter (isNotOp . getOccString)+  mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo++showExport :: forall m. (G.GhcMonad m, MonadIO m, ExceptionMonad m)+           => BrowseOpts -> ModuleInfo -> Name -> m String+showExport opt minfo e = do+  mtype' <- mtype+  return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype']+  where+    mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` optBrowseQualified opt+    mtype :: m (Maybe String)+    mtype+      | optBrowseDetailed opt || optBrowseParents opt = do+        tyInfo <- G.modInfoLookupName minfo e+        -- If nothing found, load dependent module and lookup global+        tyResult <- maybe (inOtherModule e) (return . Just) tyInfo+        dflag <- G.getSessionDynFlags+        let sig = do+                    typeName <- tyResult >>= showThing dflag+                    (" :: " ++ typeName) `justIf` optBrowseDetailed opt+        let parent = do+                    thing <- fmap getOccString $ tyResult >>= tyThingParent_maybe+                    (" -- from:" ++ thing) `justIf` optBrowseParents opt+        return $ case concat $ catMaybes [sig, parent] of+                    [] -> Nothing+                    x  -> Just x+      | otherwise = return Nothing+    formatOp nm+      | null nm    = error "formatOp"+      | isNotOp nm = nm+      | otherwise  = "(" ++ nm ++ ")"+    inOtherModule :: Name -> m (Maybe TyThing)+    inOtherModule nm = do+      G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm+    justIf :: a -> Bool -> Maybe a+    justIf x True = Just x+    justIf _ False = Nothing++showThing :: DynFlags -> TyThing -> Maybe String+showThing dflag tything = showThing' dflag (fromTyThing tything)++showThing' :: DynFlags -> GapThing -> Maybe String+showThing' dflag (GtA a) = Just $ formatType dflag a+showThing' _     (GtT t) = unwords . toList <$> tyType t+  where+    toList t' = t' : getOccString t : map getOccString (G.tyConTyVars t)+#if __GLASGOW_HASKELL__ >= 800+showThing' dflag (GtPatSyn p) = Just $ showSDoc dflag $ pprPatSynType p+#endif+showThing' _     _       = Nothing++formatType :: DynFlags -> Type -> String+formatType dflag a = showOutputable dflag (removeForAlls a)++tyType :: TyCon -> Maybe String+tyType typ+    | isAlgTyCon typ+      && not (G.isNewTyCon typ)+      && not (G.isClassTyCon typ) = Just "data"+    | G.isNewTyCon typ            = Just "newtype"+    | G.isClassTyCon typ          = Just "class"+    | Gap.isSynTyCon typ          = Just "type"+    | otherwise                   = Nothing++removeForAlls :: Type -> Type+removeForAlls ty = removeForAlls' ty' tty'+  where+    ty'  = dropForAlls ty+    tty' = splitFunTy_maybe ty'++removeForAlls' :: Type -> Maybe (Type, Type) -> Type+removeForAlls' ty Nothing = ty+removeForAlls' ty (Just (pre, ftype))+    | isPredTy pre        = mkFunTy pre (dropForAlls ftype)+    | otherwise           = ty++showOutputable :: Outputable a => DynFlags -> a -> String+showOutputable dflag = unwords . lines . showPage dflag styleUnqualified . ppr
+ GhcMod/Exe/CaseSplit.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE CPP #-}++module GhcMod.Exe.CaseSplit (+    splits+  ) where++import Data.List (find, intercalate)+import Data.Maybe (isJust)+import qualified Data.Text as T+import qualified Data.Text.IO as T (readFile)+import System.FilePath+import Prelude++import qualified DataCon as Ty+import GHC (GhcMonad, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))+import qualified GHC as G+import Outputable (PprStyle)+import qualified TyCon as Ty+import qualified Type as Ty+import Exception++import GhcMod.Convert+import GhcMod.DynFlags+import qualified GhcMod.Gap as Gap+import GhcMod.Monad+import GhcMod.SrcUtils+import GhcMod.Doc+import GhcMod.Logging+import GhcMod.Types+import GhcMod.Utils (withMappedFile)+import GhcMod.FileMapping (fileModSummaryWithMapping)+import Control.DeepSeq++----------------------------------------------------------------+-- CASE SPLITTING+----------------------------------------------------------------++data SplitInfo = SplitInfo G.Name SrcSpan (SrcSpan, Type) [SrcSpan]+               | TySplitInfo G.Name SrcSpan (SrcSpan, Ty.Kind)+data SplitToTextInfo = SplitToTextInfo { sVarName     :: String+                                       , sBindingSpan :: SrcSpan+                                       , sVarSpan     :: SrcSpan+                                       , sTycons      :: [String]+                                       }++-- | Splitting a variable in a equation.+splits :: IOish m+       => FilePath     -- ^ A target file.+       -> Int          -- ^ Line number.+       -> Int          -- ^ Column number.+       -> GhcModT m String+splits file lineNo colNo =+  ghandle handler $ runGmlT' [Left file] deferErrors $ do+      oopts <- outputOpts+      crdl <- cradle+      style <- getStyle+      dflag <- G.getSessionDynFlags+      modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl </> file)+      whenFound' oopts (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> do+          let (varName, bndLoc, (varLoc,varT))+                | (SplitInfo vn bl vlvt _matches) <- x+                = (vn, bl, vlvt)+                | (TySplitInfo vn bl vlvt) <- x+                = (vn, bl, vlvt)+              varName' = showName dflag style varName  -- Convert name to string+          t <- withMappedFile file $ \file' ->+                genCaseSplitTextFile file' (SplitToTextInfo varName' bndLoc varLoc $+                                             getTyCons dflag style varName varT)+          return $!! (fourInts bndLoc, t)+ where+   handler (SomeException ex) = do+     gmLog GmException "splits" $+           text "" $$ nest 4 (showToDoc ex)+     emptyResult =<< outputOpts++----------------------------------------------------------------+-- a. Code for getting the information of the variable++getSrcSpanTypeForSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo)+getSrcSpanTypeForSplit modSum lineNo colNo = do+  fn <- getSrcSpanTypeForFnSplit modSum lineNo colNo+  if isJust fn+     then return fn+     else getSrcSpanTypeForTypeSplit modSum lineNo colNo++-- Information for a function case split+getSrcSpanTypeForFnSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo)+getSrcSpanTypeForFnSplit modSum lineNo colNo = do+    p@ParsedModule{pm_parsed_source = _pms} <- G.parseModule modSum+    tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p+    let varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id)+        match  = last $ listifySpans tcs (lineNo, colNo) :: Gap.GLMatchI+    case varPat of+      Nothing  -> return Nothing+      Just varPat' -> do+        varT <- Gap.getType tcm varPat'  -- Finally we get the type of the var+        case varT of+          Just varT' ->+#if __GLASGOW_HASKELL__ >= 710+            let (L matchL (G.Match _ _ _ (G.GRHSs rhsLs _))) = match+#else+            let (L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match+#endif+            in return $ Just (SplitInfo (getPatternVarName varPat') matchL varT' (map G.getLoc rhsLs) )+          _ -> return Nothing++isPatternVar :: LPat Id -> Bool+isPatternVar (L _ (G.VarPat _)) = True+isPatternVar _                  = False++getPatternVarName :: LPat Id -> G.Name+#if __GLASGOW_HASKELL__ >= 800+getPatternVarName (L _ (G.VarPat (L _ vName))) = G.getName vName+#else+getPatternVarName (L _ (G.VarPat vName)) = G.getName vName+#endif+getPatternVarName _                      = error "This should never happened"++-- TODO: Information for a type family case split+getSrcSpanTypeForTypeSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo)+getSrcSpanTypeForTypeSplit _modSum _lineNo _colNo = return Nothing++----------------------------------------------------------------+-- b. Code for getting the possible constructors++getTyCons :: DynFlags -> PprStyle -> G.Name -> G.Type ->  [String]+getTyCons dflag style name ty | Just (tyCon, _) <- Ty.splitTyConApp_maybe ty =+  let name' = showName dflag style name  -- Convert name to string+  in getTyCon dflag style name' tyCon+getTyCons dflag style name _ = [showName dflag style name]++-- Write cases for one type+getTyCon :: DynFlags -> PprStyle -> String -> Ty.TyCon -> [String]+-- 1. Non-matcheable type constructors+getTyCon _ _ name tyCon | isNotMatcheableTyCon tyCon = [name]+-- 2. Special cases+-- 2.1. Tuples+getTyCon _ _ name tyCon | Ty.isTupleTyCon tyCon =+  let [uniqueDataCon] = Ty.tyConDataCons tyCon+      tupleArity = Ty.dataConSourceArity uniqueDataCon+      -- Deal with both boxed and unboxed tuples+      isUnboxed = Ty.isUnboxedTupleTyCon tyCon+      startSign = if isUnboxed then "(#" else "("+      endSign   = if isUnboxed then "#)" else ")"+  in [ startSign ++ intercalate "," (map (\n -> name ++ show n) [1 .. tupleArity]) ++ endSign ]+-- 3. General case+getTyCon dflag style name tyCon = map (getDataCon dflag style name) (Ty.tyConDataCons tyCon)++-- These type constructors should not be matched against+isNotMatcheableTyCon :: Ty.TyCon -> Bool+isNotMatcheableTyCon ty = Ty.isPrimTyCon ty  -- Primitive types, such as Int#+                       || Ty.isFunTyCon ty   -- Function types++-- Write case for one constructor+getDataCon :: DynFlags -> PprStyle -> String -> Ty.DataCon -> String+-- 1. Infix constructors+getDataCon dflag style vName dcon | Ty.dataConIsInfix dcon =+  let dName  = showName dflag style $ Ty.dataConName dcon+  in case Ty.dataConSourceArity dcon of+       0 -> dName+       1 -> vName ++ dName+       n -> if dName == ":" -- Special case for lists+            then vName ++ ":" ++ vName ++ "s"+            else newVar vName 1 ++ " " ++ dName ++ " " ++ newVars vName 2 (n-1)+-- 2. Non-record, non-infix syntax+getDataCon dflag style vName dcon | [] <- Ty.dataConFieldLabels dcon =+  let dName  = showName dflag style $ Ty.dataConName dcon+  in if last dName == '#'  -- Special case for I#, C# and so on+     then vName+     else case Ty.dataConSourceArity dcon of+            0 -> dName+            _ -> dName ++ " " ++ newVarsSpecialSingleton vName 1 (Ty.dataConSourceArity dcon)+-- 3. Records+getDataCon dflag style vName dcon =+  let dName = showName dflag style $ Ty.dataConName dcon+#if __GLASGOW_HASKELL__ >= 800+      flds  = map Ty.flSelector $ Ty.dataConFieldLabels dcon+#else+      flds  = Ty.dataConFieldLabels dcon+#endif+  in dName ++ " { " ++ showFieldNames dflag style vName flds ++ " }"++-- Create a new variable by adjoining a number+newVar :: String -> Int -> String+newVar v n = v ++ show n++-- Create a list of variables which start with the same prefix+newVars :: String -> Int -> Int -> String+newVars _ _ 0 = ""+newVars v s 1 = newVar v s+newVars v s m = newVar v s ++ " " ++ newVars v (s+1) (m-1)++-- Create a list of variables which start with the same prefix+-- Special case for a single variable, in which case no number is adjoint+newVarsSpecialSingleton :: String -> Int -> Int -> String+newVarsSpecialSingleton v _     1 = v+newVarsSpecialSingleton v start n = newVars v start n++showFieldNames :: DynFlags -> PprStyle -> String -> [G.Name] -> String+showFieldNames _     _     _ []      = "" -- This should never happen+showFieldNames dflag style v (x:xs) = let fName = showName dflag style x+                                          fAcc  = fName ++ " = " ++ v ++ "_" ++ fName+                                       in case xs of+                                            [] -> fAcc+                                            _  -> fAcc ++ ", " ++ showFieldNames dflag style v xs++----------------------------------------------------------------+-- c. Code for performing the case splitting++genCaseSplitTextFile :: (MonadIO m, GhcMonad m) =>+    FilePath -> SplitToTextInfo -> m String+genCaseSplitTextFile file info = liftIO $ do+  t <- T.readFile file+  return $ getCaseSplitText (T.lines t) info++getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String+getCaseSplitText t SplitToTextInfo{ sVarName = sVN, sBindingSpan = sBS+                                       , sVarSpan = sVS, sTycons = sT }  =+  let bindingText = getBindingText t sBS+      difference  = srcSpanDifference sBS sVS+      replaced    = map (replaceVarWithTyCon bindingText difference sVN) sT+      -- The newly generated bindings need to be indented to align with the+      -- original binding.+      replaced'   = head replaced : map (indentBindingTo sBS) (tail replaced)+   in T.unpack $ T.intercalate (T.pack "\n") (concat replaced')++getBindingText :: [T.Text] -> SrcSpan -> [T.Text]+getBindingText t srcSpan =+  let Just (sl,sc,el,ec) = Gap.getSrcSpan srcSpan+      lines_ = drop (sl - 1) $ take el t+   in if sl == el+      then -- only one line+           [T.drop (sc - 1) $ T.take ec $ head lines_]+      else -- several lines+            let (first,rest,last_) = (head lines_, tail $ init lines_, last lines_)+             in T.drop (sc - 1) first : rest ++ [T.take ec last_]++srcSpanDifference :: SrcSpan -> SrcSpan -> (Int,Int,Int,Int)+srcSpanDifference b v =+  let Just (bsl,bsc,_   ,_)  = Gap.getSrcSpan b+      Just (vsl,vsc,vel,vec) = Gap.getSrcSpan v+   in (vsl - bsl, vsc - bsc, vel - bsl, vec - bsc) -- assume variable in one line++replaceVarWithTyCon :: [T.Text] -> (Int,Int,Int,Int) -> String -> String -> [T.Text]+replaceVarWithTyCon t (vsl,vsc,_,vec) varname tycon =+  let tycon'      = if ' ' `elem` tycon || ':' `elem` tycon then "(" ++ tycon ++ ")" else tycon+      lengthDiff  = length tycon' - length varname+      tycon''     = T.pack $ if lengthDiff < 0 then tycon' ++ replicate (-lengthDiff) ' ' else tycon'+      spacesToAdd = if lengthDiff < 0 then 0 else lengthDiff+   in zipWith (\n line -> if n < vsl+                          then line  -- before variable starts+                          else if n == vsl+                               then T.take vsc line `T.append` tycon'' `T.append` T.drop vec line+                               else T.replicate spacesToAdd (T.pack " ") `T.append` line)+              [0 ..] t++indentBindingTo :: SrcSpan -> [T.Text] -> [T.Text]+indentBindingTo bndLoc binds =+  let Just (_,sl,_,_) = Gap.getSrcSpan bndLoc+      indent      = (T.replicate (sl - 1) (T.pack " ") `T.append`)+   in indent (head binds) : tail binds
+ GhcMod/Exe/Check.hs view
@@ -0,0 +1,57 @@+module GhcMod.Exe.Check (+    checkSyntax+  , check+  , expandTemplate+  , expand+  ) where++import Control.Applicative+import Prelude+import GhcMod.DynFlags+import qualified GhcMod.Gap as Gap+import GhcMod.Logger+import GhcMod.Monad++----------------------------------------------------------------++-- | Checking syntax of a target file using GHC.+--   Warnings and errors are returned.+checkSyntax :: IOish m+            => [FilePath]  -- ^ The target files.+            -> GhcModT m String+checkSyntax []    = return ""+checkSyntax files = either id id <$> check files++----------------------------------------------------------------++-- | Checking syntax of a target file using GHC.+--   Warnings and errors are returned.+check :: IOish m+      => [FilePath]  -- ^ The target files.+      -> GhcModT m (Either String String)+check files =+    runGmlTWith+      (map Left files)+      return+      ((fmap fst <$>) . withLogger Gap.setNoMaxRelevantBindings)+      (return ())++----------------------------------------------------------------++-- | Expanding Haskell Template.+expandTemplate :: IOish m+               => [FilePath]  -- ^ The target files.+               -> GhcModT m String+expandTemplate []    = return ""+expandTemplate files = either id id <$> expand files++----------------------------------------------------------------++-- | Expanding Haskell Template.+expand :: IOish m => [FilePath] -> GhcModT m (Either String String)+expand files =+    runGmlTWith+      (map Left files)+      return+      ((fmap fst <$>) . withLogger (Gap.setDumpSplices . setNoWarningFlags))+      (return ())
+ GhcMod/Exe/Debug.hs view
@@ -0,0 +1,182 @@+module GhcMod.Exe.Debug (debugInfo, rootInfo, componentInfo) where++import Control.Arrow (first)+import Control.Applicative+import Control.Monad+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Char+import Data.Maybe+import Data.Version+import Data.List.Split+import System.Directory++import GhcMod.Exe.Internal+import GhcMod.Cradle+import GhcMod.Monad+import GhcMod.Output+import GhcMod.Pretty+import GhcMod.Stack+import GhcMod.Target+import GhcMod.Types+import GhcMod.Utils++import Paths_ghc_mod (version)++import Config (cProjectVersion)+import Pretty++----------------------------------------------------------------++-- | Obtaining debug information.+debugInfo :: IOish m => GhcModT m String+debugInfo = do+    Options {..} <- options+    Cradle {..} <- cradle++    [ghcPath, ghcPkgPath] <- liftIO $+        case cradleProject of+          StackProject se ->+              catMaybes <$> sequence [getStackGhcPath se, getStackGhcPkgPath se]+          _ ->+              return ["ghc", "ghc-pkg"]++    cabal <-+        case cradleProject of+          CabalProject -> cabalDebug ghcPkgPath+          StackProject {} -> (++) <$> stackPaths <*> cabalDebug ghcPkgPath+          _ -> return []++    pkgOpts <- packageGhcOptions++    readProc <- gmReadProcess++    ghcVersion <- liftIO $+        dropWhileEnd isSpace <$> readProc ghcPath ["--numeric-version"] ""++    return $ unlines $+      [ "Version:              ghc-mod-" ++ showVersion version+      , "Library GHC Version:  " ++ cProjectVersion+      , "System GHC Version:   " ++ ghcVersion+      , "Root directory:       " ++ cradleRootDir+      , "Current directory:    " ++ cradleCurrentDir+      , "GHC Package flags:\n"   ++ renderGm (nest 4 $+              fsep $ map text pkgOpts)+      , "GHC System libraries: " ++ ghcLibDir+      ] ++ cabal++stackPaths :: IOish m => GhcModT m [String]+stackPaths = do+    Cradle { cradleProject = StackProject senv } <- cradle+    ghc <- getStackGhcPath senv+    ghcPkg <- getStackGhcPkgPath senv+    return $+         [ "Stack ghc executable:    " ++ show ghc+         , "Stack ghc-pkg executable:" ++ show ghcPkg+         ]++cabalDebug :: IOish m => FilePath -> GhcModT m [String]+cabalDebug ghcPkgPath = do+    Cradle {..} <- cradle+    mcs <- cabalResolvedComponents+    let entrypoints = Map.map gmcEntrypoints mcs+        graphs      = Map.map gmcHomeModuleGraph mcs+        opts        = Map.map gmcGhcOpts mcs+        srcOpts     = Map.map gmcGhcSrcOpts mcs++    readProc <- gmReadProcess+    cabalExists <- liftIO $ (/=Nothing) <$> findExecutable "cabal"++    cabalInstVersion <-+        if cabalExists+          then liftIO $+            dropWhileEnd isSpace <$> readProc "cabal" ["--numeric-version"] ""+          else return ""++    packages <- liftIO $ readProc ghcPkgPath ["list", "--simple-output"] ""+    let cabalPackages = filter ((== ["Cabal"]) . take 1 . splitOn "-") $ splitWhen isSpace packages++    return $+         [ "cabal-install Version: "    ++ cabalInstVersion+         , "Cabal Library Versions:\n"  ++ renderGm (nest 4 $+              fsep $ map text cabalPackages)+         , "Cabal file:            "    ++ show cradleCabalFile+         , "Project:               " ++ show cradleProject+         , "Cabal entrypoints:\n"       ++ renderGm (nest 4 $+              mapDoc gmComponentNameDoc smpDoc entrypoints)+         , "Cabal components:\n"        ++ renderGm (nest 4 $+              mapDoc gmComponentNameDoc graphDoc graphs)+         , "GHC Cabal options:\n"       ++ renderGm (nest 4 $+              mapDoc gmComponentNameDoc (fsep . map text) opts)+         , "GHC search path options:\n" ++ renderGm (nest 4 $+              mapDoc gmComponentNameDoc (fsep . map text) srcOpts)+         ]++componentInfo :: IOish m => [String] -> GhcModT m String+componentInfo ts = do+    -- TODO: most of this is copypasta of targetGhcOptions. Factor out more+    -- useful function from there.+    crdl <- cradle+    sefnmn <- Set.fromList `liftM` mapM guessModuleFile ts+    mcs <- cabalResolvedComponents+    let+        mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn+        candidates = findCandidates $ map snd mdlcs+        cn = pickComponent candidates+    opts <- targetGhcOptions crdl sefnmn++    return $ unlines $+         [ "Matching Components:\n"     ++ renderGm (nest 4 $+              alistDoc (either text mnDoc) (setDoc gmComponentNameDoc) mdlcs)+         , "Picked Component:\n"        ++ renderGm (nest 4 $+              gmComponentNameDoc cn)+         , "GHC Cabal options:\n"       ++ renderGm (nest 4 $ fsep $ map text opts)+         ]+ where+   zipMap f l = l `zip` (f `map` l)++guessModuleFile :: MonadIO m => String -> m (Either FilePath ModuleName)+guessModuleFile m+  | (isUpper . head .&&. (all $ all $ isAlphaNum .||. (=='.')) . splitOn ".") m =+      return $ Right $ mkModuleName m+ where+   infixr 1 .||.+   infixr 2 .&&.+   (.||.) = liftA2 (||)+   (.&&.) = liftA2 (&&)++guessModuleFile str = Left `liftM` liftIO (canonFilePath str)++graphDoc :: GmModuleGraph -> Doc+graphDoc GmModuleGraph{..} =+    mapDoc mpDoc smpDoc' gmgGraph+ where+   smpDoc' smp = vcat $ map mpDoc' $ Set.toList smp+   mpDoc' = text . moduleNameString . mpModule++setDoc :: (a -> Doc) -> Set.Set a -> Doc+setDoc f s = vcat $ map f $ Set.toList s++smpDoc :: Set.Set ModulePath -> Doc+smpDoc smp = setDoc mpDoc smp++mpDoc :: ModulePath -> Doc+mpDoc (ModulePath mn fn) = text (moduleNameString mn) <+> parens (text fn)++mnDoc :: ModuleName -> Doc+mnDoc mn = text (moduleNameString mn)++alistDoc :: Ord k => (k -> Doc) -> (a -> Doc) -> [(k, a)] -> Doc+alistDoc fk fa alist = mapDoc fk fa (Map.fromList alist)++mapDoc :: (k -> Doc) -> (a -> Doc) -> Map.Map k a -> Doc+mapDoc kd ad m = vcat $+    map (uncurry ($+$)) $ map (first kd) $ Map.toList $ Map.map (nest 4 . ad) m+----------------------------------------------------------------++-- | Obtaining root information.+rootInfo :: forall m. (IOish m, GmOut m, GmEnv m) => m String+rootInfo = do+    crdl <- findCradleNoLog =<< (optPrograms <$> options)+    liftIO $ cleanupCradle crdl+    return $ cradleRootDir crdl ++ "\n"
+ GhcMod/Exe/FillSig.hs view
@@ -0,0 +1,590 @@+{-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}++module GhcMod.Exe.FillSig (+    sig+  , refine+  , auto+  ) where++import Data.Char (isSymbol)+import Data.Function (on)+import Data.Functor+import Data.List (find, nub, sortBy)+import qualified Data.Map as M+import Data.Maybe (catMaybes)+import Prelude++import Exception (ghandle, SomeException(..))+import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags,+            SrcSpan, Type, GenLocated(L))+import Pretty (($$), text, nest)+import qualified GHC as G+import qualified Name as G+import Outputable (PprStyle)+import qualified Type as Ty+import qualified HsBinds as Ty+import qualified Class as Ty+import qualified Var as Ty+import qualified HsPat as Ty+import qualified Language.Haskell.Exts as HE+import Djinn.GHC++import qualified GhcMod.Gap as Gap+import GhcMod.Convert+import GhcMod.DynFlags+import GhcMod.Monad+import GhcMod.SrcUtils+import GhcMod.Logging (gmLog)+import GhcMod.Pretty (showToDoc)+import GhcMod.Doc+import GhcMod.Types+import GhcMod.FileMapping (fileModSummaryWithMapping)++#if __GLASGOW_HASKELL__ >= 710+import GHC (unLoc)+#endif++----------------------------------------------------------------+-- INTIAL CODE FROM FUNCTION OR INSTANCE SIGNATURE+----------------------------------------------------------------++-- Possible signatures we can find: function or instance+data SigInfo+    = Signature SrcSpan [G.RdrName] (G.HsType G.RdrName)+    | InstanceDecl SrcSpan G.Class+    | TyFamDecl SrcSpan G.RdrName TyFamType {- True if closed -} [G.RdrName]++-- Signature for fallback operation via haskell-src-exts+data HESigInfo+    = HESignature HE.SrcSpan [HE.Name HE.SrcSpanInfo] (HE.Type HE.SrcSpanInfo)+    | HEFamSignature+          HE.SrcSpan+          TyFamType+          (HE.Name HE.SrcSpanInfo)+          [HE.Name HE.SrcSpanInfo]++data TyFamType = Closed | Open | Data+initialTyFamString :: TyFamType -> (String, String)+initialTyFamString Closed = ("instance", "")+initialTyFamString Open   = ("function", "type instance ")+initialTyFamString Data   = ("function", "data instance ")++-- | Create a initial body from a signature.+sig :: IOish m+    => FilePath     -- ^ A target file.+    -> Int          -- ^ Line number.+    -> Int          -- ^ Column number.+    -> GhcModT m String+sig file lineNo colNo =+    runGmlT' [Left file] deferErrors $ ghandle fallback $ do+      oopts <- outputOpts+      style <- getStyle+      dflag <- G.getSessionDynFlags+      modSum <- fileModSummaryWithMapping file+      whenFound oopts (getSignature modSum lineNo colNo) $ \s ->+        case s of+          Signature loc names ty ->+              ("function", fourInts loc, map (initialBody dflag style ty) names)++          InstanceDecl loc cls ->+            let body x = initialBody dflag style (G.idType x) x+            in ("instance", fourInts loc, body `map` Ty.classMethods cls)++          TyFamDecl loc name flavour vars ->+            let (rTy, initial) = initialTyFamString flavour+                body = initialFamBody dflag style name vars+            in (rTy, fourInts loc, [initial ++ body])+  where+    fallback (SomeException _) = do+      oopts <- outputOpts+      -- Code cannot be parsed by ghc module+      -- Fallback: try to get information via haskell-src-exts+      whenFound oopts (getSignatureFromHE file lineNo colNo) $ \x -> case x of+        HESignature loc names ty ->+          ("function", fourIntsHE loc, map (initialBody undefined undefined ty) names)+        HEFamSignature loc flavour name vars ->+          let (rTy, initial) = initialTyFamString flavour+           in (rTy, fourIntsHE loc, [initial ++ initialFamBody undefined undefined name vars])++----------------------------------------------------------------+-- a. Code for getting the information++-- Get signature from ghc parsing and typechecking+getSignature :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SigInfo)+getSignature modSum lineNo colNo = do+    p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum+    -- Inspect the parse tree to find the signature+    case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsDecl G.RdrName] of+#if __GLASGOW_HASKELL__ >= 800+      [L loc (G.SigD (Ty.TypeSig names (G.HsIB _ (G.HsWC _ _ (L _ ty)))))] ->+#elif __GLASGOW_HASKELL__ >= 710+      [L loc (G.SigD (Ty.TypeSig names (L _ ty) _))] ->+#else+      [L loc (G.SigD (Ty.TypeSig names (L _ ty)))] ->+#endif+        -- We found a type signature+        return $ Just $ Signature loc (map G.unLoc names) ty+      [L _ (G.InstD _)] -> do+        -- We found an instance declaration+        TypecheckedModule{tm_renamed_source = Just tcs+                         ,tm_checked_module_info = minfo} <- G.typecheckModule p+        let lst = listifyRenamedSpans tcs (lineNo, colNo)+        case Gap.getClass lst of+            Just (clsName,loc) -> obtainClassInfo minfo clsName loc+            _                  -> return Nothing+#if __GLASGOW_HASKELL__ >= 800+      [L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars _) _ _)))] -> do+#elif __GLASGOW_HASKELL__ >= 708+      [L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars) _)))] -> do+#elif __GLASGOW_HASKELL__ >= 706+      [L loc (G.TyClD (G.TyFamily info (L _ name) (G.HsQTvs _ vars) _))] -> do+#else+      [L loc (G.TyClD (G.TyFamily info (L _ name) vars _))] -> do+#endif+#if __GLASGOW_HASKELL__ >= 708+        let flavour = case info of+                        G.ClosedTypeFamily _ -> Closed+                        G.OpenTypeFamily     -> Open+                        G.DataFamily         -> Data+#else+        let flavour = case info of  -- Closed type families where introduced in GHC 7.8+                        G.TypeFamily -> Open+                        G.DataFamily -> Data+#endif++#if __GLASGOW_HASKELL__ >= 800+            getTyFamVarName x = case x of+                L _ (G.UserTyVar (G.L _ n))     -> n+                L _ (G.KindedTyVar (G.L _ n) _) -> n+#elif __GLASGOW_HASKELL__ >= 710+            getTyFamVarName x = case x of+                L _ (G.UserTyVar n)     -> n+                L _ (G.KindedTyVar (G.L _ n) _) -> n+#elif __GLASGOW_HASKELL__ >= 706+            getTyFamVarName x = case x of+                L _ (G.UserTyVar n)     -> n+                L _ (G.KindedTyVar n _) -> n+#else+            getTyFamVarName x = case x of  -- In GHC 7.4, HsTyVarBndr's have an extra arg+                L _ (G.UserTyVar n _)     -> n+                L _ (G.KindedTyVar n _ _) -> n+#endif+         in return $ Just (TyFamDecl loc name flavour $ map getTyFamVarName vars)+      _ -> return Nothing+  where obtainClassInfo :: GhcMonad m => G.ModuleInfo -> G.Name -> SrcSpan -> m (Maybe SigInfo)+        obtainClassInfo minfo clsName loc = do+          tyThing <- G.modInfoLookupName minfo clsName+          return $ do Ty.ATyCon clsCon <- tyThing  -- In Maybe+                      cls <- G.tyConClass_maybe clsCon+                      return $ InstanceDecl loc cls++-- Get signature from haskell-src-exts+getSignatureFromHE :: (MonadIO m, GhcMonad m) =>+    FilePath -> Int -> Int -> m (Maybe HESigInfo)+getSignatureFromHE file lineNo colNo = do+  presult <- liftIO $ HE.parseFile file+  return $ case presult of+             HE.ParseOk (HE.Module _ _ _ _ mdecls) -> do+               decl <- find (typeSigInRangeHE lineNo colNo) mdecls+               case decl of+                 HE.TypeSig (HE.SrcSpanInfo s _) names ty ->+                     return $ HESignature s names ty++                 HE.TypeFamDecl (HE.SrcSpanInfo s _) declHead _ _ ->+                   let (name, tys) = dHeadTyVars declHead in+                   return $ HEFamSignature s Open name (map cleanTyVarBind tys)++                 HE.DataFamDecl (HE.SrcSpanInfo s _) _ declHead _ ->+                   let (name, tys) = dHeadTyVars declHead in+                   return $ HEFamSignature s Open name (map cleanTyVarBind tys)+                 _ -> fail ""+             _ -> Nothing+  where cleanTyVarBind (HE.KindedVar _ n _) = n+        cleanTyVarBind (HE.UnkindedVar _ n) = n++#if MIN_VERSION_haskell_src_exts(1,16,0)+        dHeadTyVars :: HE.DeclHead l -> (HE.Name l, [HE.TyVarBind l])+        dHeadTyVars (HE.DHead _ name) = (name, [])+        dHeadTyVars (HE.DHApp _ r ty) = (++[ty]) `fmap` (dHeadTyVars r)+        dHeadTyVars (HE.DHInfix _ ty name) = (name, [ty])+        dHeadTyVars (HE.DHParen _ r) = dHeadTyVars r+#else+        dHeadTyVars :: HE.DeclHead l -> (HE.Name l, [HE.TyVarBind l])+        dHeadTyVars (HE.DHead _ n tys) = (n, tys)+#endif++----------------------------------------------------------------+-- b. Code for generating initial code++-- A list of function arguments, and whether they are functions or normal+-- arguments is built from either a function signature or an instance signature+data FnArg = FnArgFunction | FnArgNormal | FnExplicitName String++initialBody :: FnArgsInfo ty name => DynFlags -> PprStyle -> ty -> name -> String+initialBody dflag style ty name =+    initialBody' (getFnName dflag style name) (getFnArgs ty)++initialBody' :: String -> [FnArg] -> String+initialBody' fname args =+    initialHead fname args ++ " = " ++ n ++ "_body"+ where n = if isSymbolName fname then "" else '_':fname++initialFamBody :: FnArgsInfo ty name+               => DynFlags -> PprStyle -> name -> [name] -> String+initialFamBody dflag style name args =+    initialHead fnName fnArgs ++ " = ()"+ where fnName = getFnName dflag style name+       fnArgs = map (FnExplicitName . getFnName dflag style) args++initialHead :: String -> [FnArg] -> String+initialHead fname args =+  case initialBodyArgs args infiniteVars infiniteFns of+    []      -> fname+    arglist -> if isSymbolName fname+               then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)+               else fname ++ " " ++ unwords arglist++initialBodyArgs :: [FnArg] -> [String] -> [String] -> [String]+initialBodyArgs [] _ _ = []+initialBodyArgs (FnArgFunction:xs) vs (f:fs) = f : initialBodyArgs xs vs fs+initialBodyArgs (FnArgNormal:xs)   (v:vs) fs = v : initialBodyArgs xs vs fs+initialBodyArgs (FnExplicitName n:xs)  vs fs = n : initialBodyArgs xs vs fs+initialBodyArgs _                  _      _  =+    error "initialBodyArgs: This should never happen" -- Lists are infinite++initialHead1 :: String -> [FnArg] -> [String] -> String+initialHead1 fname args elts =+  case initialBodyArgs1 args elts of+    []      -> fname+    arglist+      | isSymbolName fname ->+        head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)+      | otherwise ->+        fname ++ " " ++ unwords arglist++initialBodyArgs1 :: [FnArg] -> [String] -> [String]+initialBodyArgs1 args elts = take (length args) elts++-- Getting the initial body of function and instances differ+-- This is because for functions we only use the parsed file+-- (so the full file doesn't have to be type correct)+-- but for instances we need to get information about the class++class FnArgsInfo ty name | ty -> name, name -> ty where+  getFnName :: DynFlags -> PprStyle -> name -> String+  getFnArgs :: ty -> [FnArg]++instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where+  getFnName dflag style name = showOccName dflag style $ Gap.occName name+#if __GLASGOW_HASKELL__ >= 800+  getFnArgs (G.HsForAllTy _ (L _ iTy))+#elif __GLASGOW_HASKELL__ >= 710+  getFnArgs (G.HsForAllTy _ _ _ _ (L _ iTy))+#else+  getFnArgs (G.HsForAllTy _ _ _ (L _ iTy))+#endif+    = getFnArgs iTy++  getFnArgs (G.HsParTy (L _ iTy))           = getFnArgs iTy+  getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) =+      (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy+    where fnarg ty = case ty of+#if __GLASGOW_HASKELL__ >= 800+              (G.HsForAllTy _ (L _ iTy)) ->+#elif __GLASGOW_HASKELL__ >= 710+              (G.HsForAllTy _ _ _ _ (L _ iTy)) ->+#else+              (G.HsForAllTy _ _ _ (L _ iTy)) ->+#endif+                fnarg iTy++              (G.HsParTy (L _ iTy))          -> fnarg iTy+              (G.HsFunTy _ _)                -> True+              _                              -> False+  getFnArgs _ = []++instance FnArgsInfo (HE.Type HE.SrcSpanInfo) (HE.Name HE.SrcSpanInfo) where+  getFnName _ _ (HE.Ident  _ s) = s+  getFnName _ _ (HE.Symbol _ s) = s+  getFnArgs (HE.TyForall _ _ _ iTy) = getFnArgs iTy+  getFnArgs (HE.TyParen _ iTy)      = getFnArgs iTy+  getFnArgs (HE.TyFun _ lTy rTy)    =+      (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy+    where fnarg ty = case ty of+              (HE.TyForall _ _ _ iTy) -> fnarg iTy+              (HE.TyParen _ iTy)      -> fnarg iTy+              (HE.TyFun _ _ _)        -> True+              _                       -> False+  getFnArgs _ = []++instance FnArgsInfo Type Id where+  getFnName dflag style method = showOccName dflag style $ G.getOccName method+  getFnArgs = getFnArgs' . Ty.dropForAlls+    where getFnArgs' ty | Just (lTy,rTy) <- Ty.splitFunTy_maybe ty =+            maybe (if Ty.isPredTy lTy then getFnArgs' rTy else FnArgNormal:getFnArgs' rTy)+                  (\_ -> FnArgFunction:getFnArgs' rTy)+                  $ Ty.splitFunTy_maybe lTy++          getFnArgs' ty | Just (_,iTy) <- Ty.splitForAllTy_maybe ty =+              getFnArgs' iTy++          getFnArgs' _ = []++-- Infinite supply of variable and function variable names+infiniteVars, infiniteFns :: [String]+infiniteVars = infiniteSupply ["x","y","z","t","u","v","w"]+infiniteFns  = infiniteSupply ["f","g","h"]+infiniteSupply :: [String] -> [String]+infiniteSupply initialSupply =+    initialSupply ++ concatMap (\n -> map (\v -> v ++ show n) initialSupply)+                               ([1 .. ] :: [Integer])++-- Check whether a String is a symbol name+isSymbolName :: String -> Bool+isSymbolName (c:_) = c `elem` "!#$%&*+./<=>?@\\^|-~" || isSymbol c+isSymbolName []    = error "This should never happen"+++----------------------------------------------------------------+-- REWRITE A HOLE / UNDEFINED VIA A FUNCTION+----------------------------------------------------------------++refine :: IOish m+       => FilePath     -- ^ A target file.+       -> Int          -- ^ Line number.+       -> Int          -- ^ Column number.+       -> Expression   -- ^ A Haskell expression.+       -> GhcModT m String+refine file lineNo colNo (Expression expr) =+  ghandle handler $+    runGmlT' [Left file] deferErrors $ do+      oopts <- outputOpts+      style <- getStyle+      dflag <- G.getSessionDynFlags+      modSum <- fileModSummaryWithMapping file+      p <- G.parseModule modSum+      tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p+      ety <- G.exprType expr+      whenFound oopts (findVar dflag style tcm tcs lineNo colNo) $+        \(loc, name, rty, paren) ->+            let eArgs = getFnArgs ety+                rArgs = getFnArgs rty+                diffArgs' = length eArgs - length rArgs+                diffArgs  = if diffArgs' < 0 then 0 else diffArgs'+                iArgs = take diffArgs eArgs+                txt = initialHead1 expr iArgs (infinitePrefixSupply name)+             in (fourInts loc, doParen paren txt)+  where+   handler (SomeException ex) = do+     gmLog GmException "refining" $+           text "" $$ nest 4 (showToDoc ex)+     emptyResult =<< outputOpts++-- Look for the variable in the specified position+findVar+  :: GhcMonad m+  => DynFlags+  -> PprStyle+  -> G.TypecheckedModule+  -> G.TypecheckedSource+  -> Int+  -> Int+  -> m (Maybe (SrcSpan, String, Type, Bool))+findVar dflag style tcm tcs lineNo colNo =+  case lst of+#if __GLASGOW_HASKELL__ >= 800+    e@(L _ (G.HsVar (L _ i))):others -> do+#else+    e@(L _ (G.HsVar i)):others -> do+#endif+      tyInfo <- Gap.getType tcm e+      case tyInfo of+        Just (s, typ)+          | name == "undefined" || head name == '_' ->+            return $ Just (s, name, typ, b)+          where+            name = getFnName dflag style i+            -- If inside an App, we need parenthesis+            b = case others of+                  L _ (G.HsApp (L _ a1) (L _ a2)):_ ->+                    isSearchedVar i a1 || isSearchedVar i a2+                  _  -> False+        _ -> return Nothing+    _ -> return Nothing+  where+    lst :: [G.LHsExpr Id]+    lst = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo)++infinitePrefixSupply :: String -> [String]+infinitePrefixSupply "undefined" = repeat "undefined"+infinitePrefixSupply p = map (\n -> p ++ "_" ++ show n) ([1 ..] :: [Integer])++doParen :: Bool -> String -> String+doParen False s = s+doParen True  s = if ' ' `elem` s then '(':s ++ ")" else s++isSearchedVar :: Id -> G.HsExpr Id -> Bool+#if __GLASGOW_HASKELL__ >= 800+isSearchedVar i (G.HsVar (L _ i2)) = i == i2+#else+isSearchedVar i (G.HsVar i2) = i == i2+#endif+isSearchedVar _ _ = False+++----------------------------------------------------------------+-- REFINE AUTOMATICALLY+----------------------------------------------------------------++auto :: IOish m+     => FilePath     -- ^ A target file.+     -> Int          -- ^ Line number.+     -> Int          -- ^ Column number.+     -> GhcModT m String+auto file lineNo colNo =+  ghandle handler $ runGmlT' [Left file] deferErrors $ do+        oopts <- outputOpts+        style <- getStyle+        dflag <- G.getSessionDynFlags+        modSum <- fileModSummaryWithMapping file+        p <- G.parseModule modSum+        tcm@TypecheckedModule {+                 tm_typechecked_source = tcs+               , tm_checked_module_info = minfo+               } <- G.typecheckModule p+        whenFound' oopts (findVar dflag style tcm tcs lineNo colNo) $ \(loc, _name, rty, paren) -> do+          topLevel <- getEverythingInTopLevel minfo+          let (f,pats) = getPatsForVariable tcs (lineNo,colNo)+              -- Remove self function to prevent recursion, and id to trim+              -- cases+              filterFn (n,_) = let funName = G.getOccString n+                                   recName = G.getOccString (G.getName f)+                               in funName `notElem` recName:notWantedFuns+              -- Find without using other functions in top-level+              localBnds = M.unions $+                  map (\(L _ pat) -> getBindingsForPat pat) pats+              lbn = filter filterFn (M.toList localBnds)+          djinnsEmpty <- djinn True (Just minfo) lbn rty (Max 10) 100000+          let -- Find with the entire top-level+              almostEnv = M.toList $ M.union localBnds topLevel+              env = filter filterFn almostEnv+          djinns <- djinn True (Just minfo) env rty (Max 10) 100000+          return ( fourInts loc+                 , map (doParen paren) $ nub (djinnsEmpty ++ djinns))+ where+   handler (SomeException ex) = do+     gmLog GmException "auto-refining" $+           text "" $$ nest 4 (showToDoc ex)+     emptyResult =<< outputOpts++-- Functions we do not want in completions+notWantedFuns :: [String]+notWantedFuns = ["id", "asTypeOf", "const"]++-- Get all things defined in top-level+getEverythingInTopLevel :: GhcMonad m => G.ModuleInfo -> m (M.Map G.Name Type)+getEverythingInTopLevel m = do+  let modInfo  = tyThingsToInfo (G.modInfoTyThings m)+      topNames = G.modInfoTopLevelScope m+  case topNames of+    Just topNames' -> do topThings <- mapM G.lookupGlobalName topNames'+                         let topThings' = catMaybes topThings+                             topInfo    = tyThingsToInfo topThings'+                         return $ M.union modInfo topInfo+    Nothing -> return modInfo++tyThingsToInfo :: [Ty.TyThing] -> M.Map G.Name Type+tyThingsToInfo [] = M.empty+tyThingsToInfo (G.AnId i : xs) =+    M.insert (G.getName i) (Ty.varType i) (tyThingsToInfo xs)+-- Getting information about constructors is not needed+-- because they will be added by djinn-ghc when traversing types+-- #if __GLASGOW_HASKELL__ >= 708+-- tyThingToInfo (G.AConLike (G.RealDataCon con)) = return [(Ty.dataConName con, Ty.dataConUserType con)]+-- #else+-- tyThingToInfo (G.AConLike con) = return [(Ty.dataConName con, Ty.dataConUserType con)]+-- #endif+tyThingsToInfo (_:xs) = tyThingsToInfo xs++-- Find the Id of the function and the pattern where the hole is located+getPatsForVariable :: G.TypecheckedSource -> (Int,Int) -> (Id, [Ty.LPat Id])+getPatsForVariable tcs (lineNo, colNo) =+  let (L _ bnd:_) = sortBy (cmp `on` G.getLoc) $+                      listifySpans tcs (lineNo, colNo) :: [G.LHsBind Id]+   in case bnd of+        G.PatBind { Ty.pat_lhs = L ploc pat }  -> case pat of+          Ty.ConPatIn (L _ i) _ -> (i, [L ploc pat])+          _                     -> (error "This should never happen", [])+        G.FunBind { Ty.fun_id = L _ funId } ->+          let m = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo)+#if __GLASGOW_HASKELL__ >= 708+                    :: [G.LMatch Id (G.LHsExpr Id)]+#else+                    :: [G.LMatch Id]+#endif+#if __GLASGOW_HASKELL__ >= 710+              (L _ (G.Match _ pats _ _):_) = m+#else+              (L _ (G.Match pats _ _):_) = m+#endif+           in (funId, pats)+        _ -> (error "This should never happen", [])++getBindingsForPat :: Ty.Pat Id -> M.Map G.Name Type+#if __GLASGOW_HASKELL__ >= 800+getBindingsForPat (Ty.VarPat (L _ i)) = M.singleton (G.getName i) (Ty.varType i)+#else+getBindingsForPat (Ty.VarPat i) = M.singleton (G.getName i) (Ty.varType i)+#endif+getBindingsForPat (Ty.LazyPat (L _ l)) = getBindingsForPat l+getBindingsForPat (Ty.BangPat (L _ b)) = getBindingsForPat b+getBindingsForPat (Ty.AsPat (L _ a) (L _ i)) =+    M.insert (G.getName a) (Ty.varType a) (getBindingsForPat i)+#if __GLASGOW_HASKELL__ >= 708+getBindingsForPat (Ty.ListPat  l _ _) =+    M.unions $ map (\(L _ i) -> getBindingsForPat i) l+#else+getBindingsForPat (Ty.ListPat  l _)   =+    M.unions $ map (\(L _ i) -> getBindingsForPat i) l+#endif+getBindingsForPat (Ty.TuplePat l _ _) =+    M.unions $ map (\(L _ i) -> getBindingsForPat i) l+getBindingsForPat (Ty.PArrPat  l _)   =+    M.unions $ map (\(L _ i) -> getBindingsForPat i) l+getBindingsForPat (Ty.ViewPat _ (L _ i) _) = getBindingsForPat i+getBindingsForPat (Ty.SigPatIn  (L _ i) _) = getBindingsForPat i+getBindingsForPat (Ty.SigPatOut (L _ i) _) = getBindingsForPat i+getBindingsForPat (Ty.ConPatIn (L _ i) d) =+    M.insert (G.getName i) (Ty.varType i) (getBindingsForRecPat d)+getBindingsForPat (Ty.ConPatOut { Ty.pat_args = d }) = getBindingsForRecPat d+getBindingsForPat _ = M.empty++getBindingsForRecPat :: Ty.HsConPatDetails Id -> M.Map G.Name Type+#if __GLASGOW_HASKELL__ >= 800+getBindingsForRecPat (G.PrefixCon args) =+#else+getBindingsForRecPat (Ty.PrefixCon args) =+#endif+    M.unions $ map (\(L _ i) -> getBindingsForPat i) args+#if __GLASGOW_HASKELL__ >= 800+getBindingsForRecPat (G.InfixCon (L _ a1) (L _ a2)) =+#else+getBindingsForRecPat (Ty.InfixCon (L _ a1) (L _ a2)) =+#endif+    M.union (getBindingsForPat a1) (getBindingsForPat a2)+#if __GLASGOW_HASKELL__ >= 800+getBindingsForRecPat (G.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) =+#else+getBindingsForRecPat (Ty.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) =+#endif+    getBindingsForRecFields (map unLoc' fields)+ where+#if __GLASGOW_HASKELL__ >= 710+   unLoc' = unLoc+#else+   unLoc' = id+#endif+   getBindingsForRecFields [] = M.empty+   getBindingsForRecFields (Ty.HsRecField {Ty.hsRecFieldArg = (L _ a)}:fs) =+       M.union (getBindingsForPat a) (getBindingsForRecFields fs)
+ GhcMod/Exe/Find.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE CPP, BangPatterns, TupleSections, DeriveGeneric #-}++module GhcMod.Exe.Find+  ( Symbol+  , SymbolDb+  , loadSymbolDb+  , lookupSymbol+  , dumpSymbol+  , findSymbol+  , lookupSym+  , isOutdated+  -- * Load 'SymbolDb' asynchronously+  , AsyncSymbolDb+  , newAsyncSymbolDb+  , getAsyncSymbolDb+  ) where++import qualified GHC as G+import FastString+import Module+import OccName+import HscTypes+import Exception++import GhcMod.Convert+import GhcMod.Gap+import GhcMod.Monad+import GhcMod.Output+import GhcMod.Types+import GhcMod.Utils+import GhcMod.World+import GhcMod.LightGhc++import Control.Applicative+import Control.DeepSeq+import Control.Monad+import Control.Monad.Trans.Control+import Control.Concurrent++import Data.List+import Data.Binary+import Data.Function+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Data.IORef++import System.Directory.ModTime+import System.IO.Unsafe++import GHC.Generics (Generic)++import Data.Map (Map)+import qualified Data.Map as M+import Data.Set (Set)+import qualified Data.Set as S+import GhcMod.PathsAndFiles+import System.Directory+import Prelude++----------------------------------------------------------------++-- | Type of function and operation names.+type Symbol = BS.ByteString+type ModuleNameBS = BS.ByteString++-- | Database from 'Symbol' to \['ModuleString'\].+data SymbolDb = SymbolDb+  { sdTable             :: Map Symbol (Set ModuleNameBS)+  , sdTimestamp         :: ModTime+  } deriving (Generic)++#if __GLASGOW_HASKELL__ >= 708+instance Binary SymbolDb+#else+instance Binary SymbolDb where+  put (SymbolDb a b) = put a >> put b+  get = do+    a <- get+    b <- get+    return (SymbolDb a b)+#endif+instance NFData SymbolDb++isOutdated :: IOish m => SymbolDb -> GhcModT m Bool+isOutdated db =+  isOlderThan (sdTimestamp db) <$> timedPackageCaches++----------------------------------------------------------------++-- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]+--   which will be concatenated. 'loadSymbolDb' is called internally.+findSymbol :: IOish m => String -> GhcModT m String+findSymbol sym = loadSymbolDb' >>= lookupSymbol sym++-- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]+--   which will be concatenated.+lookupSymbol :: IOish m => String -> SymbolDb -> GhcModT m String+lookupSymbol sym db = convert' $ lookupSym (fastStringToByteString $ mkFastString sym) db++lookupSym :: Symbol -> SymbolDb -> [ModuleString]+lookupSym sym db = map (ModuleString . unpackFS . mkFastStringByteString') $ S.toList $ M.findWithDefault S.empty sym $ sdTable db++---------------------------------------------------------------++loadSymbolDb' :: IOish m => GhcModT m SymbolDb+loadSymbolDb' = do+  cache <- symbolCache <$> cradle+  let doLoad True = do+        db <- decode <$> liftIO (LBS.readFile cache)+        outdated <- isOutdated db+        if outdated+        then doLoad False+        else return db+      doLoad False = do+        db <- loadSymbolDb+        liftIO $ LBS.writeFile cache $ encode db+        return db+  doLoad =<< liftIO (doesFileExist cache)++-- | Loading a file and creates 'SymbolDb'.+loadSymbolDb :: IOish m => GhcModT m SymbolDb+loadSymbolDb = do+  ghcMod <- liftIO ghcModExecutable+  readProc <- gmReadProcess'+  out <- liftIO $ readProc ghcMod ["--verbose", "error", "dumpsym"] ""+  return $!! decode out++----------------------------------------------------------------+-- used 'ghc-mod dumpsym'++-- | Dumps a 'Binary' representation of 'SymbolDb' to stdout+dumpSymbol :: IOish m => GhcModT m ()+dumpSymbol = do+  ts <- liftIO getCurrentModTime+  st <- runGmPkgGhc $ getGlobalSymbolTable+  liftIO . LBS.putStr $ encode SymbolDb {+      sdTable = st+    , sdTimestamp = ts+    }++-- | Check whether given file is older than any file from the given set.+-- Returns True if given file does not exist.+isOlderThan :: ModTime -> [TimedFile] -> Bool+isOlderThan tCache files =+  any (tCache <=) $ map tfTime files -- including equal just in case++-- | Browsing all functions in all system modules.+getGlobalSymbolTable :: (G.GhcMonad m, MonadIO m)+                     => m (Map Symbol (Set ModuleNameBS))+getGlobalSymbolTable =+  foldM extend M.empty =<< (listVisibleModules <$> G.getSessionDynFlags)++extend :: (G.GhcMonad m, MonadIO m)+       => Map Symbol (Set ModuleNameBS)+       -> Module+       -> m (Map Symbol (Set ModuleNameBS))+extend mm mdl = do+  hsc_env <- G.getSession+  eps <- liftIO $ readIORef $ hsc_EPS hsc_env+  modinfo <- liftIO $ unsafeInterleaveIO $ runLightGhc hsc_env $ do+    G.getModuleInfo mdl <* liftIO (writeIORef (hsc_EPS hsc_env) eps)+  return $ M.unionWith S.union mm $ extractBindings modinfo mdl++extractBindings :: Maybe G.ModuleInfo+                -> G.Module+                -> Map Symbol (Set ModuleNameBS)+extractBindings Nothing  _   = M.empty+extractBindings (Just inf) mdl = M.fromList $ do+  name <- G.modInfoExports inf+  let sym = fastStringToByteString $ occNameFS $ G.getOccName name+      mdls = S.singleton $ fastStringToByteString $ moduleNameFS $ moduleName mdl+  return (sym, mdls)++mkFastStringByteString' :: BS.ByteString -> FastString+#if !MIN_VERSION_ghc(7,8,0)+fastStringToByteString :: FastString -> BS.ByteString+fastStringToByteString = BS.pack . bytesFS++mkFastStringByteString' = mkFastStringByteList . BS.unpack+#elif __GLASGOW_HASKELL__ == 708+mkFastStringByteString' = unsafePerformIO . mkFastStringByteString+#else+mkFastStringByteString' = mkFastStringByteString+#endif++----------------------------------------------------------------++data AsyncSymbolDb = AsyncSymbolDb (MVar (Either SomeException SymbolDb))++asyncLoadSymbolDb :: IOish m+                  => MVar (Either SomeException SymbolDb)+                  -> GhcModT m ()+asyncLoadSymbolDb mv = void $+    liftBaseWith $ \run -> forkIO $ void $ run $ do+      edb <- gtry loadSymbolDb+      liftIO $ putMVar mv edb++newAsyncSymbolDb :: IOish m => GhcModT m AsyncSymbolDb+newAsyncSymbolDb = do+    mv <- liftIO newEmptyMVar+    asyncLoadSymbolDb mv+    return $ AsyncSymbolDb mv++getAsyncSymbolDb :: forall m. IOish m => AsyncSymbolDb -> GhcModT m SymbolDb+getAsyncSymbolDb (AsyncSymbolDb mv) = do+  db <- liftIO $ handleEx <$> takeMVar mv+  outdated <- isOutdated db+  if outdated+    then do+      asyncLoadSymbolDb mv+      liftIO $ handleEx <$> readMVar mv+    else do+      liftIO $ putMVar mv $ Right db+      return db+ where+   handleEx edb =+     case edb of+       Left ex -> throw ex+       Right db -> db
+ GhcMod/Exe/Flag.hs view
@@ -0,0 +1,9 @@+module GhcMod.Exe.Flag where++import qualified GhcMod.Gap as Gap+import GhcMod.Convert+import GhcMod.Monad++-- | Listing of GHC flags, same as @ghc@\'s @--show-options@ with @ghc >= 7.10@.+flags :: IOish m => GhcModT m String+flags = convert' Gap.ghcCmdOptions
+ GhcMod/Exe/Info.hs view
@@ -0,0 +1,79 @@+module GhcMod.Exe.Info (+    info+  , types+  ) where++import Data.Function (on)+import Data.List (sortBy)+import System.FilePath+import Exception (ghandle, SomeException(..))+import GHC (GhcMonad, SrcSpan)+import Prelude+import qualified GHC as G++import qualified GhcMod.Gap as Gap+import GhcMod.Convert+import GhcMod.Doc+import GhcMod.DynFlags+import GhcMod.Gap+import GhcMod.Logging+import GhcMod.Monad+import GhcMod.SrcUtils+import GhcMod.Types+import GhcMod.Utils (mkRevRedirMapFunc)+import GhcMod.FileMapping (fileModSummaryWithMapping)++----------------------------------------------------------------++-- | Obtaining information of a target expression. (GHCi's info:)+info :: IOish m+     => FilePath     -- ^ A target file.+     -> Expression   -- ^ A Haskell expression.+     -> GhcModT m String+info file expr =+  ghandle handler $+    runGmlT' [Left file] deferErrors $+      withInteractiveContext $ do+        convert' =<< body+  where+    handler (SomeException ex) = do+      gmLog GmException "info" $ text "" $$ nest 4 (showToDoc ex)+      convert' "Cannot show info"++    body :: (GhcMonad m, GmState m, GmEnv m) => m String+    body = do+      m <- mkRevRedirMapFunc+      sdoc  <- Gap.infoThing m expr+      st    <- getStyle+      dflag <- G.getSessionDynFlags+      return $ showPage dflag st sdoc++----------------------------------------------------------------++-- | Obtaining type of a target expression. (GHCi's type:)+types :: IOish m+      => Bool         -- ^ Include constraints into type signature+      -> FilePath     -- ^ A target file.+      -> Int          -- ^ Line number.+      -> Int          -- ^ Column number.+      -> GhcModT m String+types withConstraints file lineNo colNo =+  ghandle handler $+    runGmlT' [Left file] deferErrors $+      withInteractiveContext $ do+        crdl         <- cradle+        modSum       <- fileModSummaryWithMapping (cradleCurrentDir crdl </> file)+        srcSpanTypes <- getSrcSpanType withConstraints modSum lineNo colNo+        dflag        <- G.getSessionDynFlags+        st           <- getStyle+        convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes+ where+   handler (SomeException ex) = do+     gmLog GmException "types" $ showToDoc ex+     return []++getSrcSpanType :: (GhcMonad m) => Bool -> G.ModSummary -> Int -> Int -> m [(SrcSpan, G.Type)]+getSrcSpanType withConstraints modSum lineNo colNo =+  G.parseModule modSum+  >>= G.typecheckModule+  >>= flip (collectSpansTypes withConstraints) (lineNo, colNo)
+ GhcMod/Exe/Internal.hs view
@@ -0,0 +1,73 @@+-- | Low level access to the ghc-mod library.++module GhcMod.Exe.Internal (+  -- * Types+    GHCOption+  , IncludeDir+  , GmlT(..)+  , MonadIO(..)+  , GmEnv(..)+  -- * Various Paths+  , ghcLibDir+  , ghcModExecutable+  -- * Logging+  , withLogger+  , setNoWarningFlags+  , setAllWarningFlags+  -- * Environment, state and logging+  , GhcModEnv(..)+  , GhcModState+  , GhcModLog+  , GmLog(..)+  , GmLogLevel(..)+  , gmSetLogLevel+  -- * Monad utilities+  , runGhcModT'+  , hoistGhcModT+  , runGmlT+  , runGmlT'+  , gmlGetSession+  , gmlSetSession+  , loadTargets+  , cabalResolvedComponents+  -- ** Accessing 'GhcModEnv' and 'GhcModState'+  , options+  , cradle+  , targetGhcOptions+  , withOptions+  -- * 'GhcModError'+  , gmeDoc+  -- * World+  , World+  , getCurrentWorld+  , didWorldChange+  -- * Cabal Helper+  , ModulePath(..)+  , GmComponent(..)+  , GmComponentType(..)+  , GmModuleGraph(..)+  , prepareCabalHelper+  -- * Misc stuff+  , GHandler(..)+  , gcatches+  -- * FileMapping+  , module GhcMod.FileMapping+  ) where++import GHC.Paths (libdir)++import GhcMod.Target+import GhcMod.DynFlags+import GhcMod.Error+import GhcMod.Logger+import GhcMod.Logging+import GhcMod.Monad+import GhcMod.Types+import GhcMod.Utils+import GhcMod.World+import GhcMod.CabalHelper+import GhcMod.FileMapping++-- | Obtaining the directory for ghc system libraries.+ghcLibDir :: FilePath+ghcLibDir = libdir
+ GhcMod/Exe/Lang.hs view
@@ -0,0 +1,10 @@+module GhcMod.Exe.Lang where++import DynFlags (supportedLanguagesAndExtensions)+import GhcMod.Convert+import GhcMod.Monad++-- | Listing language extensions.++languages :: IOish m => GhcModT m String+languages = convert' supportedLanguagesAndExtensions
+ GhcMod/Exe/Lint.hs view
@@ -0,0 +1,30 @@+module GhcMod.Exe.Lint where++import Exception (ghandle)+import Control.Exception (SomeException(..))+import GhcMod.Logger (checkErrorPrefix)+import GhcMod.Convert+import GhcMod.Types+import GhcMod.Monad+import Language.Haskell.HLint3++import GhcMod.Utils (withMappedFile)+import Language.Haskell.Exts.SrcLoc (SrcSpan(..))++-- | Checking syntax of a target file using hlint.+--   Warnings and errors are returned.+lint :: IOish m+     => LintOpts  -- ^ Configuration parameters+     -> FilePath  -- ^ A target file.+     -> GhcModT m String+lint opt file = ghandle handler $+  withMappedFile file $ \tempfile -> do+    res <- liftIO $ hlint $ "--quiet" : tempfile : optLintHlintOpts opt+    pack . map (show . substFile file tempfile) $ res+  where+    pack = convert' . map init -- init drops the last \n.+    handler (SomeException e) = return $ checkErrorPrefix ++ show e ++ "\n"+    substFile orig temp idea+      | srcSpanFilename (ideaSpan idea) == temp+      = idea{ideaSpan=(ideaSpan idea){srcSpanFilename = orig}}+    substFile _ _ idea = idea
+ GhcMod/Exe/Modules.hs view
@@ -0,0 +1,27 @@+module GhcMod.Exe.Modules (modules) where++import Control.Arrow+import Data.List+import GhcMod.Convert+import GhcMod.Types+import GhcMod.Monad+import GhcMod.Gap ( listVisibleModuleNames+                                   , lookupModulePackageInAllPackages+                                   )++import qualified GHC as G++----------------------------------------------------------------++-- | Listing installed modules.+modules :: (IOish m, Gm m)+        => Bool -- ^ 'detailed', if 'True', also prints packages that modules belong to.+        -> m String+modules detailed = do+  df <- runGmPkgGhc G.getSessionDynFlags+  let mns = listVisibleModuleNames df+      pmnss = map (first moduleNameString) $ zip mns (modulePkg df `map` mns)+  convert' $ nub [ if detailed then pkg ++ " " ++ mn else mn+                 | (mn, pkgs) <- pmnss, pkg <- pkgs ]+ where+   modulePkg df = lookupModulePackageInAllPackages df
+ GhcMod/Exe/PkgDoc.hs view
@@ -0,0 +1,29 @@+module GhcMod.Exe.PkgDoc (pkgDoc) where++import GhcMod.Types+import GhcMod.GhcPkg+import GhcMod.Monad+import GhcMod.Output++import Control.Applicative+import Prelude++-- | Obtaining the package name and the doc path of a module.+pkgDoc :: IOish m => String -> GhcModT m String+pkgDoc mdl = do+    ghcPkg <- getGhcPkgProgram+    readProc <- gmReadProcess+    pkgDbStack <- getPackageDbStack+    pkg <- liftIO $ trim <$> readProc ghcPkg (toModuleOpts pkgDbStack) ""+    if pkg == "" then+        return "\n"+      else do+        htmlpath <- liftIO $ readProc ghcPkg (toDocDirOpts pkg pkgDbStack) ""+        let ret = pkg ++ " " ++ drop 14 htmlpath+        return ret+  where+    toModuleOpts dbs = ["find-module", mdl, "--simple-output"]+                   ++ ghcPkgDbStackOpts dbs+    toDocDirOpts pkg dbs = ["field", pkg, "haddock-html"]+                       ++ ghcPkgDbStackOpts dbs+    trim = takeWhile (`notElem` " \n")
+ GhcMod/Exe/Test.hs view
@@ -0,0 +1,45 @@+module GhcMod.Exe.Test where++import Control.Applicative+import Data.List+import System.FilePath+import System.Directory+import Prelude++import GhcMod.Types+import GhcMod.Monad+import GhcMod.DynFlags++import GHC+import GHC.Exception+import OccName++test :: IOish m+      => FilePath -> GhcModT m String+test f = runGmlT' [Left f] (fmap setHscInterpreted . deferErrors) $ do+    mg <- getModuleGraph+    root <- cradleRootDir <$> cradle+    f' <- makeRelative root <$> liftIO (canonicalizePath f)+    let Just ms = find ((==Just f') . ml_hs_file . ms_location) mg+        mdl = ms_mod ms+        mn = moduleName mdl++    Just mi <- getModuleInfo mdl+    let exs = map (occNameString . getOccName) $ modInfoExports mi+        cqs = filter ("prop_" `isPrefixOf`) exs++    setContext [ IIDecl $ simpleImportDecl mn+               , IIDecl $ simpleImportDecl $ mkModuleName "Test.QuickCheck"+               ]++    _res <- mapM runTest cqs++    return ""++runTest :: GhcMonad m => String -> m (Maybe SomeException)+runTest fn = do+  res <- runStmt ("quickCheck " ++ fn) RunToCompletion+  return $ case res of+    RunOk [] -> Nothing+    RunException se -> Just se+    _ -> error "runTest"
− LICENSE 
@@ -1,29 +0,0 @@-Copyright (c) 2009, IIJ Innovation Institute Inc.-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions-are met:--  * Redistributions of source code must retain the above copyright-    notice, this list of conditions and the following disclaimer.-  * Redistributions in binary form must reproduce the above copyright-    notice, this list of conditions and the following disclaimer in-    the documentation and/or other materials provided with the-    distribution.-  * Neither the name of the copyright holders nor the names of its-    contributors may be used to endorse or promote products derived-    from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS-FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE-COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,-INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,-BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;-LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER-CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT-LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN-ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE-POSSIBILITY OF SUCH DAMAGE.
− Language/Haskell/GhcMod.hs 
@@ -1,66 +0,0 @@--- | The ghc-mod library.--module Language.Haskell.GhcMod (-  -- * Cradle-    Cradle(..)-  , findCradle-  -- * Options-  , Options(..)-  , LineSeparator(..)-  , OutputStyle(..)-  , defaultOptions-  -- * Types-  , ModuleString-  , Expression-  , GhcPkgDb-  , Symbol-  , SymbolDb-  , GhcModError(..)-  -- * Monad Types-  , GhcModT-  , IOish-  -- * Monad utilities-  , runGhcModT-  , withOptions-  -- * 'GhcMod' utilities-  , boot-  , browse-  , check-  , checkSyntax-  , debugInfo-  , expandTemplate-  , info-  , lint-  , pkgDoc-  , rootInfo-  , types-  , splits-  , sig-  , refine-  , auto-  , modules-  , languages-  , flags-  , findSymbol-  , lookupSymbol-  , dumpSymbol-  -- * SymbolDb-  , loadSymbolDb-  ) where--import Language.Haskell.GhcMod.Boot-import Language.Haskell.GhcMod.Browse-import Language.Haskell.GhcMod.CaseSplit-import Language.Haskell.GhcMod.Check-import Language.Haskell.GhcMod.Cradle-import Language.Haskell.GhcMod.Debug-import Language.Haskell.GhcMod.FillSig-import Language.Haskell.GhcMod.Find-import Language.Haskell.GhcMod.Flag-import Language.Haskell.GhcMod.Info-import Language.Haskell.GhcMod.Lang-import Language.Haskell.GhcMod.Lint-import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.Modules-import Language.Haskell.GhcMod.PkgDoc-import Language.Haskell.GhcMod.Types
− Language/Haskell/GhcMod/Boot.hs 
@@ -1,25 +0,0 @@-module Language.Haskell.GhcMod.Boot where--import Control.Applicative-import Language.Haskell.GhcMod.Browse-import Language.Haskell.GhcMod.Flag-import Language.Haskell.GhcMod.Lang-import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.Modules---- | Printing necessary information for front-end booting.-boot :: IOish m => GhcModT m String-boot =  concat <$> sequence [modules, languages, flags,-                             concat <$> mapM browse preBrowsedModules]--preBrowsedModules :: [String]-preBrowsedModules = [-    "Prelude"-  , "Control.Applicative"-  , "Control.Exception"-  , "Control.Monad"-  , "Data.Char"-  , "Data.List"-  , "Data.Maybe"-  , "System.IO"-  ]
− Language/Haskell/GhcMod/Browse.hs 
@@ -1,136 +0,0 @@-module Language.Haskell.GhcMod.Browse (-    browse-  ) where--import Control.Applicative ((<$>))-import Control.Exception (SomeException(..))-import Data.Char (isAlpha)-import Data.List (sort)-import Data.Maybe (catMaybes)-import Exception (ghandle)-import FastString (mkFastString)-import GHC (GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon)-import qualified GHC as G-import Language.Haskell.GhcMod.Convert-import Language.Haskell.GhcMod.Doc (showPage, styleUnqualified)-import Language.Haskell.GhcMod.Gap-import Language.Haskell.GhcMod.Monad (GhcModT, options)-import Language.Haskell.GhcMod.Target (setTargetFiles)-import Language.Haskell.GhcMod.Types-import Name (getOccString)-import Outputable (ppr, Outputable)-import TyCon (isAlgTyCon)-import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy)---------------------------------------------------------------------- | Getting functions, classes, etc from a module.---   If 'detailed' is 'True', their types are also obtained.---   If 'operators' is 'True', operators are also returned.-browse :: IOish m-       => ModuleString -- ^ A module name. (e.g. \"Data.List\")-       -> GhcModT m String-browse pkgmdl = convert' . sort =<< (listExports =<< getModule)-  where-    (mpkg,mdl) = splitPkgMdl pkgmdl-    mdlname = G.mkModuleName mdl-    mpkgid = mkFastString <$> mpkg-    listExports Nothing       = return []-    listExports (Just mdinfo) = processExports mdinfo-    -- findModule works only for package modules, moreover,-    -- you cannot load a package module. On the other hand,-    -- to browse a local module you need to load it first.-    -- If CmdLineError is signalled, we assume the user-    -- tried browsing a local module.-    getModule = browsePackageModule `G.gcatch` fallback `G.gcatch` handler-    browsePackageModule = G.findModule mdlname mpkgid >>= G.getModuleInfo-    browseLocalModule = ghandle handler $ do-      setTargetFiles [mdl]-      G.findModule mdlname Nothing >>= G.getModuleInfo-    fallback (CmdLineError _) = browseLocalModule-    fallback _                = return Nothing-    handler (SomeException _) = return Nothing--- |------ >>> splitPkgMdl "base:Prelude"--- (Just "base","Prelude")--- >>> splitPkgMdl "Prelude"--- (Nothing,"Prelude")-splitPkgMdl :: String -> (Maybe String,String)-splitPkgMdl pkgmdl = case break (==':') pkgmdl of-    (mdl,"")    -> (Nothing,mdl)-    (pkg,_:mdl) -> (Just pkg,mdl)--processExports :: IOish m => ModuleInfo -> GhcModT m [String]-processExports minfo = do-  opt <- options-  let-    removeOps-      | operators opt = id-      | otherwise = filter (isAlpha . head . getOccString)-  mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo--showExport :: IOish m => Options -> ModuleInfo -> Name -> GhcModT m String-showExport opt minfo e = do-  mtype' <- mtype-  return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype']-  where-    mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` qualified opt-    mtype :: IOish m => GhcModT m (Maybe String)-    mtype-      | detailed opt = do-        tyInfo <- G.modInfoLookupName minfo e-        -- If nothing found, load dependent module and lookup global-        tyResult <- maybe (inOtherModule e) (return . Just) tyInfo-        dflag <- G.getSessionDynFlags-        return $ do-          typeName <- tyResult >>= showThing dflag-          (" :: " ++ typeName) `justIf` detailed opt-      | otherwise = return Nothing-    formatOp nm@(n:_)-      | isAlpha n = nm-      | otherwise = "(" ++ nm ++ ")"-    formatOp "" = error "formatOp"-    inOtherModule :: IOish m => Name -> GhcModT m (Maybe TyThing)-    inOtherModule nm = G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm-    justIf :: a -> Bool -> Maybe a-    justIf x True = Just x-    justIf _ False = Nothing--showThing :: DynFlags -> TyThing -> Maybe String-showThing dflag tything = showThing' dflag (fromTyThing tything)--showThing' :: DynFlags -> GapThing -> Maybe String-showThing' dflag (GtA a) = Just $ formatType dflag a-showThing' _     (GtT t) = unwords . toList <$> tyType t-  where-    toList t' = t' : getOccString t : map getOccString (G.tyConTyVars t)-showThing' _     _       = Nothing--formatType :: DynFlags -> Type -> String-formatType dflag a = showOutputable dflag (removeForAlls a)--tyType :: TyCon -> Maybe String-tyType typ-    | isAlgTyCon typ-      && not (G.isNewTyCon typ)-      && not (G.isClassTyCon typ) = Just "data"-    | G.isNewTyCon typ            = Just "newtype"-    | G.isClassTyCon typ          = Just "class"-    | G.isSynTyCon typ            = Just "type"-    | otherwise                   = Nothing--removeForAlls :: Type -> Type-removeForAlls ty = removeForAlls' ty' tty'-  where-    ty'  = dropForAlls ty-    tty' = splitFunTy_maybe ty'--removeForAlls' :: Type -> Maybe (Type, Type) -> Type-removeForAlls' ty Nothing = ty-removeForAlls' ty (Just (pre, ftype))-    | isPredTy pre        = mkFunTy pre (dropForAlls ftype)-    | otherwise           = ty--showOutputable :: Outputable a => DynFlags -> a -> String-showOutputable dflag = unwords . lines . showPage dflag styleUnqualified . ppr
− Language/Haskell/GhcMod/Cabal16.hs 
@@ -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)
− Language/Haskell/GhcMod/Cabal18.hs 
@@ -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)
− Language/Haskell/GhcMod/Cabal21.hs 
@@ -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)
− Language/Haskell/GhcMod/CabalApi.hs 
@@ -1,193 +0,0 @@-{-# LANGUAGE OverloadedStrings, CPP #-}--module Language.Haskell.GhcMod.CabalApi (-    getCompilerOptions-  , parseCabalFile-  , cabalAllBuildInfo-  , cabalDependPackages-  , cabalSourceDirs-  , cabalAllTargets-  , cabalConfigDependencies-  ) where--import Language.Haskell.GhcMod.CabalConfig-import Language.Haskell.GhcMod.Error-import Language.Haskell.GhcMod.Gap (benchmarkBuildInfo, benchmarkTargets,-                                    toModuleString)-import Language.Haskell.GhcMod.GhcPkg-import Language.Haskell.GhcMod.Types--import MonadUtils (liftIO)-import Control.Applicative ((<$>))-import qualified Control.Exception as E-import Control.Monad (filterM)-import Data.Maybe (maybeToList)-import Data.Set (fromList, toList)-import Distribution.Package (Dependency(Dependency)-                           , PackageName(PackageName))-import qualified Distribution.Package as C-import Distribution.PackageDescription (PackageDescription, BuildInfo, TestSuite, TestSuiteInterface(..), Executable)-import qualified Distribution.PackageDescription as P-import Distribution.PackageDescription.Configuration (finalizePackageDescription)-import Distribution.PackageDescription.Parse (readPackageDescription)-import Distribution.Simple.Compiler (CompilerId(..), CompilerFlavor(..))-import Distribution.Simple.Program (ghcProgram)-import Distribution.Simple.Program.Types (programName, programFindVersion)-import Distribution.System (buildPlatform)-import Distribution.Text (display)-import Distribution.Verbosity (silent)-import Distribution.Version (Version)-import System.Directory (doesFileExist)-import System.FilePath ((</>))--------------------------------------------------------------------- | Getting necessary 'CompilerOptions' from three information sources.-getCompilerOptions :: (IOish m, MonadError GhcModError m)-                   => [GHCOption]-                   -> Cradle-                   -> PackageDescription-                   -> m CompilerOptions-getCompilerOptions ghcopts cradle pkgDesc = do-    gopts <- liftIO $ getGHCOptions ghcopts cradle rdir $ head buildInfos-    depPkgs <- cabalConfigDependencies cradle (C.packageId pkgDesc)-    return $ CompilerOptions gopts idirs depPkgs-  where-    wdir       = cradleCurrentDir cradle-    rdir       = cradleRootDir    cradle-    buildInfos = cabalAllBuildInfo pkgDesc-    idirs      = includeDirectories rdir wdir $ cabalSourceDirs buildInfos--------------------------------------------------------------------- Include directories for modules--cabalBuildDirs :: [FilePath]-cabalBuildDirs = ["dist/build", "dist/build/autogen"]--includeDirectories :: FilePath -> FilePath -> [FilePath] -> [FilePath]-includeDirectories cdir wdir dirs = uniqueAndSort (extdirs ++ [cdir,wdir])-  where-    extdirs = map expand $ dirs ++ cabalBuildDirs-    expand "."    = cdir-    expand subdir = cdir </> subdir---------------------------------------------------------------------- | Parse a cabal file and return a 'PackageDescription'.-parseCabalFile :: (IOish m, MonadError GhcModError m)-               => Cradle-               -> FilePath-               -> m PackageDescription-parseCabalFile cradle file = do-    cid <- liftIO getGHCId-    epgd <- liftIO $ readPackageDescription silent file-    flags <- cabalConfigFlags cradle-    case toPkgDesc cid flags epgd of-        Left deps    -> fail $ show deps ++ " are not installed"-        Right (pd,_) -> if nullPkg pd-                        then fail $ file ++ " is broken"-                        else return pd-  where-    toPkgDesc cid flags =-        finalizePackageDescription flags (const True) buildPlatform cid []-    nullPkg pd = name == ""-      where-        PackageName name = C.pkgName (P.package pd)--------------------------------------------------------------------getGHCOptions :: [GHCOption] -> Cradle -> FilePath -> BuildInfo -> IO [GHCOption]-getGHCOptions ghcopts cradle rdir binfo = do-    cabalCpp <- cabalCppOptions rdir-    let cpps = map ("-optP" ++) $ P.cppOptions binfo ++ cabalCpp-    return $ ghcopts ++ pkgDb ++ exts ++ [lang] ++ libs ++ libDirs ++ cpps-  where-    pkgDb = ghcDbStackOpts $ cradlePkgDbStack cradle-    lang = maybe "-XHaskell98" (("-X" ++) . display) $ P.defaultLanguage binfo-    libDirs = map ("-L" ++) $ P.extraLibDirs binfo-    exts = map (("-X" ++) . display) $ P.usedExtensions binfo-    libs = map ("-l" ++) $ P.extraLibs binfo--cabalCppOptions :: FilePath -> IO [String]-cabalCppOptions dir = do-    exist <- doesFileExist cabalMacro-    return $ if exist then-        ["-include", cabalMacro]-      else-        []-  where-    cabalMacro = dir </> "dist/build/autogen/cabal_macros.h"---------------------------------------------------------------------- | Extracting all 'BuildInfo' for libraries, executables, and tests.-cabalAllBuildInfo :: PackageDescription -> [BuildInfo]-cabalAllBuildInfo pd = libBI ++ execBI ++ testBI ++ benchBI-  where-    libBI   = map P.libBuildInfo       $ maybeToList $ P.library pd-    execBI  = map P.buildInfo          $ P.executables pd-    testBI  = map P.testBuildInfo      $ P.testSuites pd-    benchBI = benchmarkBuildInfo pd---------------------------------------------------------------------- | Extracting package names of dependency.-cabalDependPackages :: [BuildInfo] -> [PackageBaseName]-cabalDependPackages bis = uniqueAndSort pkgs-  where-    pkgs = map getDependencyPackageName $ concatMap P.targetBuildDepends bis-    getDependencyPackageName (Dependency (PackageName nm) _) = nm---------------------------------------------------------------------- | Extracting include directories for modules.-cabalSourceDirs :: [BuildInfo] -> [IncludeDir]-cabalSourceDirs bis = uniqueAndSort $ concatMap P.hsSourceDirs bis--------------------------------------------------------------------uniqueAndSort :: [String] -> [String]-uniqueAndSort = toList . fromList--------------------------------------------------------------------getGHCId :: IO CompilerId-getGHCId = CompilerId GHC <$> getGHC--getGHC :: IO Version-getGHC = do-    mv <- programFindVersion ghcProgram silent (programName ghcProgram)-    case mv of-      -- TODO: MonadError it up-        Nothing -> E.throwIO $ userError "ghc not found"-        Just v  -> return v---------------------------------------------------------------------- | Extracting all 'Module' 'FilePath's for libraries, executables,--- tests and benchmarks.-cabalAllTargets :: PackageDescription -> IO ([String],[String],[String],[String])-cabalAllTargets pd = do-    exeTargets  <- mapM getExecutableTarget $ P.executables pd-    testTargets <- mapM getTestTarget $ P.testSuites pd-    return (libTargets,concat exeTargets,concat testTargets,benchTargets)-  where-    lib = case P.library pd of-            Nothing -> []-            Just l -> P.libModules l--    libTargets = map toModuleString lib-    benchTargets = benchmarkTargets pd--    getTestTarget :: TestSuite -> IO [String]-    getTestTarget ts =-       case P.testInterface ts of-        (TestSuiteExeV10 _ filePath) -> do-          let maybeTests = [p </> e | p <- P.hsSourceDirs $ P.testBuildInfo ts, e <- [filePath]]-          liftIO $ filterM doesFileExist maybeTests-        (TestSuiteLibV09 _ moduleName) -> return [toModuleString moduleName]-        (TestSuiteUnsupported _)       -> return []--    getExecutableTarget :: Executable -> IO [String]-    getExecutableTarget exe = do-      let maybeExes = [p </> e | p <- P.hsSourceDirs $ P.buildInfo exe, e <- [P.modulePath exe]]-      liftIO $ filterM doesFileExist maybeExes
− Language/Haskell/GhcMod/CabalConfig.hs 
@@ -1,177 +0,0 @@-{-# LANGUAGE CPP #-}---- | This module facilitates extracting information from Cabal's on-disk--- 'LocalBuildInfo' (@dist/setup-config@).-module Language.Haskell.GhcMod.CabalConfig (-    CabalConfig-  , cabalConfigDependencies-  , cabalConfigFlags-  ) where--import Language.Haskell.GhcMod.Error-import Language.Haskell.GhcMod.GhcPkg-import Language.Haskell.GhcMod.Utils-import Language.Haskell.GhcMod.Read-import Language.Haskell.GhcMod.Types--import qualified Language.Haskell.GhcMod.Cabal16 as C16-import qualified Language.Haskell.GhcMod.Cabal18 as C18-import qualified Language.Haskell.GhcMod.Cabal21 as C21--#ifndef MIN_VERSION_mtl-#define MIN_VERSION_mtl(x,y,z) 1-#endif--import Control.Applicative ((<$>))-import Control.Monad (mplus)-#if MIN_VERSION_mtl(2,2,1)-import Control.Monad.Except ()-#else-import Control.Monad.Error ()-#endif-import Data.Maybe ()-import Data.Set ()-import Data.List (find,tails,isPrefixOf,isInfixOf,nub,stripPrefix)-import Distribution.Package (InstalledPackageId(..)-                           , PackageIdentifier(..)-                           , PackageName(..))-import Distribution.PackageDescription (FlagAssignment)-import Distribution.Simple.BuildPaths (defaultDistPref)-import Distribution.Simple.Configure (localBuildInfoFile)-import Distribution.Simple.LocalBuildInfo (ComponentName)-import MonadUtils (liftIO)-import System.FilePath ((</>))---------------------------------------------------------------------- | 'Show'ed cabal 'LocalBuildInfo' string-type CabalConfig = String---- | Get contents of the file containing 'LocalBuildInfo' data. If it doesn't--- exist run @cabal configure@ i.e. configure with default options like @cabal--- build@ would do.-getConfig :: (IOish m, MonadError GhcModError m)-          => Cradle-          -> m CabalConfig-getConfig cradle = liftIO (readFile path) `tryFix` \_ ->-     configure `modifyError'` GMECabalConfigure- where-   prjDir = cradleRootDir cradle-   path = prjDir </> configPath--   configure :: (IOish m, MonadError GhcModError m) => m ()-   configure =-       withDirectory_ prjDir $ readProcess' "cabal" ["configure"] >> return ()----- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@-configPath :: FilePath-configPath = localBuildInfoFile defaultDistPref---- | Get list of 'Package's needed by all components of the current package-cabalConfigDependencies :: (IOish m, MonadError GhcModError m)-                        => Cradle-                        -> PackageIdentifier-                        -> m [Package]-cabalConfigDependencies cradle thisPkg =-    configDependencies thisPkg <$> getConfig cradle---- | Extract list of depencenies for all components from 'CabalConfig'-configDependencies :: PackageIdentifier -> CabalConfig -> [Package]-configDependencies thisPkg config = map fromInstalledPackageId deps- where-    deps :: [InstalledPackageId]-    deps = case deps21 `mplus` deps18 `mplus` deps16 of-        Right ps -> ps-        Left msg -> error msg--    -- True if this dependency is an internal one (depends on the library-    -- defined in the same package).-    internal pkgid = pkgid == thisPkg--    -- Cabal >= 1.21-    deps21 :: Either String [InstalledPackageId]-    deps21 =-        map fst-      <$> filterInternal21-      <$> (readEither =<< extractField config "componentsConfigs")--    filterInternal21-        :: [(ComponentName, C21.ComponentLocalBuildInfo, [ComponentName])]-        -> [(InstalledPackageId, C21.PackageIdentifier)]--    filterInternal21 ccfg = [ (ipkgid, pkgid)-                          | (_,clbi,_)      <- ccfg-                          , (ipkgid, pkgid) <- C21.componentPackageDeps clbi-                          , not (internal . packageIdentifierFrom21 $ pkgid) ]--    packageIdentifierFrom21 :: C21.PackageIdentifier -> PackageIdentifier-    packageIdentifierFrom21 (C21.PackageIdentifier (C21.PackageName myName) myVersion) =-        PackageIdentifier (PackageName myName) myVersion--    -- Cabal >= 1.18 && < 1.21-    deps18 :: Either String [InstalledPackageId]-    deps18 =-          map fst-      <$> filterInternal-      <$> (readEither =<< extractField config "componentsConfigs")--    filterInternal-        :: [(ComponentName, C18.ComponentLocalBuildInfo, [ComponentName])]-        -> [(InstalledPackageId, PackageIdentifier)]--    filterInternal ccfg = [ (ipkgid, pkgid)-                          | (_,clbi,_)      <- ccfg-                          , (ipkgid, pkgid) <- C18.componentPackageDeps clbi-                          , not (internal pkgid) ]--    -- Cabal 1.16 and below-    deps16 :: Either String [InstalledPackageId]-    deps16 = map fst <$> filter (not . internal . snd) . nub <$> do-        cbi <- concat <$> sequence [ extract "executableConfigs"-                                   , extract "testSuiteConfigs"-                                   , extract "benchmarkConfigs" ]-                        :: Either String [(String, C16.ComponentLocalBuildInfo)]--        return $ maybe [] C16.componentPackageDeps libraryConfig-              ++ concatMap (C16.componentPackageDeps . snd) cbi-     where-       libraryConfig :: Maybe C16.ComponentLocalBuildInfo-       libraryConfig = do-         field <- find ("libraryConfig" `isPrefixOf`) (tails config)-         clbi <- stripPrefix " = " field-         if "Nothing" `isPrefixOf` clbi-             then Nothing-             else case readMaybe =<< stripPrefix "Just " clbi of-                    Just x -> x-                    Nothing -> error $ "reading libraryConfig failed\n" ++ show (stripPrefix "Just " clbi)--       extract :: String -> Either String [(String, C16.ComponentLocalBuildInfo)]-       extract field = readConfigs field <$> extractField config field--       readConfigs :: String -> String -> [(String, C16.ComponentLocalBuildInfo)]-       readConfigs f s = case readEither s of-           Right x -> x-           Left msg -> error $ "reading config " ++ f ++ " failed ("++msg++")"---- | Get the flag assignment from the local build info of the given cradle-cabalConfigFlags :: (IOish m, MonadError GhcModError m)-                 => Cradle-                 -> m FlagAssignment-cabalConfigFlags cradle = do-  config <- getConfig cradle-  case configFlags config of-    Right x  -> return x-    Left msg -> throwError (GMECabalFlags (GMEString msg))---- | Extract the cabal flags from the 'CabalConfig'-configFlags :: CabalConfig -> Either String FlagAssignment-configFlags config = readEither =<< flip extractField "configConfigurationsFlags" =<< extractField config "configFlags"---- | Find @field@ in 'CabalConfig'. Returns 'Left' containing a user readable--- error message with lots of context on failure.-extractField :: CabalConfig -> String -> Either String String-extractField config field =-    case extractParens <$> find (field `isPrefixOf`) (tails config) of-        Just f -> Right f-        Nothing -> Left $ "extractField: failed extracting "++field++" from input, input contained `"++field++"'? " ++ show (field `isInfixOf` config)
− Language/Haskell/GhcMod/CaseSplit.hs 
@@ -1,222 +0,0 @@-{-# LANGUAGE CPP #-}--module Language.Haskell.GhcMod.CaseSplit (-    splits-  ) where--import Data.List (find, intercalate)-import Data.Maybe (isJust)-import qualified Data.Text as T-import qualified Data.Text.IO as T (readFile)-import qualified DataCon as Ty-import Exception (ghandle, SomeException(..))-import GHC (GhcMonad, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))-import qualified GHC as G-import Language.Haskell.GhcMod.Convert-import qualified Language.Haskell.GhcMod.Gap as Gap-import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.SrcUtils-import Outputable (PprStyle)-import qualified TyCon as Ty-import qualified Type as Ty--------------------------------------------------------------------- CASE SPLITTING-------------------------------------------------------------------data SplitInfo = SplitInfo G.Name SrcSpan (SrcSpan, Type) [SrcSpan]-               | TySplitInfo G.Name SrcSpan (SrcSpan, Ty.Kind)-data SplitToTextInfo = SplitToTextInfo { sVarName     :: String-                                       , sBindingSpan :: SrcSpan-                                       , sVarSpan     :: SrcSpan-                                       , sTycons      :: [String]-                                       }---- | Splitting a variable in a equation.-splits :: IOish m-       => FilePath     -- ^ A target file.-       -> Int          -- ^ Line number.-       -> Int          -- ^ Column number.-       -> GhcModT m String-splits file lineNo colNo = ghandle handler body-  where-    body = inModuleContext file $ \dflag style -> do-        opt <- options-        modSum <- Gap.fileModSummary file-        whenFound' opt (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of-          (SplitInfo varName bndLoc (varLoc,varT) _matches) -> do-             let varName' = showName dflag style varName  -- Convert name to string-             text <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $-                                                getTyCons dflag style varName varT)-             return (fourInts bndLoc, text)-          (TySplitInfo varName bndLoc (varLoc,varT)) -> do-             let varName' = showName dflag style varName  -- Convert name to string-             text <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $-                                                getTyCons dflag style varName varT)-             return (fourInts bndLoc, text)-    handler (SomeException _) = emptyResult =<< options--------------------------------------------------------------------- a. Code for getting the information of the variable--getSrcSpanTypeForSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo)-getSrcSpanTypeForSplit modSum lineNo colNo = do-  fn <- getSrcSpanTypeForFnSplit modSum lineNo colNo-  if isJust fn-     then return fn-     else getSrcSpanTypeForTypeSplit modSum lineNo colNo---- Information for a function case split-getSrcSpanTypeForFnSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo)-getSrcSpanTypeForFnSplit modSum lineNo colNo = do-    p@ParsedModule{pm_parsed_source = _pms} <- G.parseModule modSum-    tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p-    let varPat  = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id)-        match:_ = listifySpans tcs (lineNo, colNo) :: [Gap.GLMatchI]-    case varPat of-      Nothing  -> return Nothing-      Just varPat' -> do-        varT <- Gap.getType tcm varPat'  -- Finally we get the type of the var-        case varT of-          Just varT' ->-            let (L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match-            in return $ Just (SplitInfo (getPatternVarName varPat') matchL varT' (map G.getLoc rhsLs) )-          _ -> return Nothing--isPatternVar :: LPat Id -> Bool-isPatternVar (L _ (G.VarPat _)) = True-isPatternVar _                  = False--getPatternVarName :: LPat Id -> G.Name-getPatternVarName (L _ (G.VarPat vName)) = G.getName vName-getPatternVarName _                      = error "This should never happened"---- TODO: Information for a type family case split-getSrcSpanTypeForTypeSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo)-getSrcSpanTypeForTypeSplit _modSum _lineNo _colNo = return Nothing--------------------------------------------------------------------- b. Code for getting the possible constructors--getTyCons :: DynFlags -> PprStyle -> G.Name -> G.Type ->  [String]-getTyCons dflag style name ty | Just (tyCon, _) <- Ty.splitTyConApp_maybe ty =-  let name' = showName dflag style name  -- Convert name to string-  in getTyCon dflag style name' tyCon-getTyCons dflag style name _ = [showName dflag style name]---- Write cases for one type-getTyCon :: DynFlags -> PprStyle -> String -> Ty.TyCon -> [String]--- 1. Non-matcheable type constructors-getTyCon _ _ name tyCon | isNotMatcheableTyCon tyCon = [name]--- 2. Special cases--- 2.1. Tuples-getTyCon _ _ name tyCon | Ty.isTupleTyCon tyCon =-  let [uniqueDataCon] = Ty.tyConDataCons tyCon-      tupleArity = Ty.dataConSourceArity uniqueDataCon-      -- Deal with both boxed and unboxed tuples-      isUnboxed = Ty.isUnboxedTupleTyCon tyCon-      startSign = if isUnboxed then "(#" else "("-      endSign   = if isUnboxed then "#)" else ")"-  in [ startSign ++ intercalate "," (map (\n -> name ++ show n) [1 .. tupleArity]) ++ endSign ]--- 3. General case-getTyCon dflag style name tyCon = map (getDataCon dflag style name) (Ty.tyConDataCons tyCon)---- These type constructors should not be matched against-isNotMatcheableTyCon :: Ty.TyCon -> Bool-isNotMatcheableTyCon ty = Ty.isPrimTyCon ty  -- Primitive types, such as Int#-                       || Ty.isFunTyCon ty   -- Function types---- Write case for one constructor-getDataCon :: DynFlags -> PprStyle -> String -> Ty.DataCon -> String--- 1. Infix constructors-getDataCon dflag style vName dcon | Ty.dataConIsInfix dcon =-  let dName  = showName dflag style $ Ty.dataConName dcon-  in case Ty.dataConSourceArity dcon of-       0 -> dName-       1 -> vName ++ dName-       n -> if dName == ":" -- Special case for lists-            then vName ++ ":" ++ vName ++ "s"-            else newVar vName 1 ++ " " ++ dName ++ " " ++ newVars vName 2 (n-1)--- 2. Non-record, non-infix syntax-getDataCon dflag style vName dcon | [] <- Ty.dataConFieldLabels dcon =-  let dName  = showName dflag style $ Ty.dataConName dcon-  in if last dName == '#'  -- Special case for I#, C# and so on-     then vName-     else case Ty.dataConSourceArity dcon of-            0 -> dName-            _ -> dName ++ " " ++ newVarsSpecialSingleton vName 1 (Ty.dataConSourceArity dcon)--- 3. Records-getDataCon dflag style vName dcon =-  let dName = showName dflag style $ Ty.dataConName dcon-      flds  = Ty.dataConFieldLabels dcon-  in dName ++ " { " ++ showFieldNames dflag style vName flds ++ " }"---- Create a new variable by adjoining a number-newVar :: String -> Int -> String-newVar v n = v ++ show n---- Create a list of variables which start with the same prefix-newVars :: String -> Int -> Int -> String-newVars _ _ 0 = ""-newVars v s 1 = newVar v s-newVars v s m = newVar v s ++ " " ++ newVars v (s+1) (m-1)---- Create a list of variables which start with the same prefix--- Special case for a single variable, in which case no number is adjoint-newVarsSpecialSingleton :: String -> Int -> Int -> String-newVarsSpecialSingleton v _     1 = v-newVarsSpecialSingleton v start n = newVars v start n--showFieldNames :: DynFlags -> PprStyle -> String -> [G.Name] -> String-showFieldNames _     _     _ []      = "" -- This should never happen-showFieldNames dflag style v (x:xs) = let fName = showName dflag style x-                                          fAcc  = fName ++ " = " ++ v ++ "_" ++ fName-                                       in case xs of-                                            [] -> fAcc-                                            _  -> fAcc ++ ", " ++ showFieldNames dflag style v xs--------------------------------------------------------------------- c. Code for performing the case splitting--genCaseSplitTextFile :: GhcMonad m => FilePath -> SplitToTextInfo -> m String-genCaseSplitTextFile file info = liftIO $ do-  text <- T.readFile file-  return $ getCaseSplitText (T.lines text) info--getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String-getCaseSplitText text (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS-                                       , sVarSpan = sVS, sTycons = sT })  =-  let bindingText = getBindingText text sBS-      difference  = srcSpanDifference sBS sVS-      replaced    = concatMap (replaceVarWithTyCon bindingText difference sVN) sT-   in T.unpack $ T.intercalate (T.pack "\n") replaced--getBindingText :: [T.Text] -> SrcSpan -> [T.Text]-getBindingText text srcSpan =-  let Just (sl,sc,el,ec) = Gap.getSrcSpan srcSpan-      lines_ = drop (sl - 1) $ take el text-   in if sl == el-      then -- only one line-           [T.drop (sc - 1) $ T.take ec $ head lines_]-      else -- several lines-            let (first,rest,last_) = (head lines_, tail $ init lines_, last lines_)-             in T.drop (sc - 1) first : rest ++ [T.take ec last_]--srcSpanDifference :: SrcSpan -> SrcSpan -> (Int,Int,Int,Int)-srcSpanDifference b v =-  let Just (bsl,bsc,_   ,_)  = Gap.getSrcSpan b-      Just (vsl,vsc,vel,vec) = Gap.getSrcSpan v-   in (vsl - bsl, vsc - bsc, vel - bsl, vec - bsc) -- assume variable in one line--replaceVarWithTyCon :: [T.Text] -> (Int,Int,Int,Int) -> String -> String -> [T.Text]-replaceVarWithTyCon text (vsl,vsc,_,vec) varname tycon =-  let tycon'      = if ' ' `elem` tycon || ':' `elem` tycon then "(" ++ tycon ++ ")" else tycon-      lengthDiff  = length tycon' - length varname-      tycon''     = T.pack $ if lengthDiff < 0 then tycon' ++ replicate (-lengthDiff) ' ' else tycon'-      spacesToAdd = if lengthDiff < 0 then 0 else lengthDiff-   in zipWith (\n line -> if n < vsl-                          then line  -- before variable starts-                          else if n == vsl-                               then T.take vsc line `T.append` tycon'' `T.append` T.drop vec line-                               else T.replicate spacesToAdd (T.pack " ") `T.append` line)-              [0 ..] text
− Language/Haskell/GhcMod/Check.hs 
@@ -1,54 +0,0 @@-module Language.Haskell.GhcMod.Check (-    checkSyntax-  , check-  , expandTemplate-  , expand-  ) where--import Control.Applicative ((<$>))-import Language.Haskell.GhcMod.DynFlags-import qualified Language.Haskell.GhcMod.Gap as Gap-import qualified GHC as G-import Language.Haskell.GhcMod.Logger-import Language.Haskell.GhcMod.Monad (IOish, GhcModT, overrideGhcUserOptions)-import Language.Haskell.GhcMod.Target (setTargetFiles)---------------------------------------------------------------------- | Checking syntax of a target file using GHC.---   Warnings and errors are returned.-checkSyntax :: IOish m-            => [FilePath]  -- ^ The target files.-            -> GhcModT m String-checkSyntax []    = return ""-checkSyntax files = either id id <$> check files---------------------------------------------------------------------- | Checking syntax of a target file using GHC.---   Warnings and errors are returned.-check :: IOish m-      => [FilePath]  -- ^ The target files.-      -> GhcModT m (Either String String)-check fileNames = overrideGhcUserOptions $ \ghcOpts -> do-  withLogger (setAllWarningFlags . setNoMaxRelevantBindings . Gap.setWarnTypedHoles . Gap.setDeferTypeErrors) $ do-    _ <- G.setSessionDynFlags =<< addCmdOpts ghcOpts =<< G.getSessionDynFlags-    setTargetFiles fileNames---------------------------------------------------------------------- | Expanding Haskell Template.-expandTemplate :: IOish m-               => [FilePath]  -- ^ The target files.-               -> GhcModT m String-expandTemplate []    = return ""-expandTemplate files = either id id <$> expand files---------------------------------------------------------------------- | Expanding Haskell Template.-expand :: IOish m-       => [FilePath]  -- ^ The target files.-       -> GhcModT m (Either String String)-expand fileNames = withLogger (Gap.setDumpSplices . setNoWarningFlags) $-    setTargetFiles fileNames
− Language/Haskell/GhcMod/Convert.hs 
@@ -1,135 +0,0 @@-{-# LANGUAGE FlexibleInstances, FlexibleContexts, OverlappingInstances #-}--module Language.Haskell.GhcMod.Convert (convert, convert', emptyResult, whenFound, whenFound') where--import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.Types--import Control.Applicative ((<$>))--type Builder = String -> String---- |------ >>> replace '"' "\\\"" "foo\"bar" ""--- "foo\\\"bar"-replace :: Char -> String -> String -> Builder-replace _ _  [] = id-replace c cs (x:xs)-  | x == c    = (cs ++) . replace c cs xs-  | otherwise = (x :) . replace c cs xs--inter :: Char -> [Builder] -> Builder-inter _ [] = id-inter c bs = foldr1 (\x y -> x . (c:) . y) bs--convert' :: (ToString a, IOish m) => a -> GhcModT m String-convert' x = flip convert x <$> options--convert :: ToString a => Options -> a -> String-convert opt@Options { outputStyle = LispStyle  } x = toLisp  opt x "\n"-convert opt@Options { outputStyle = PlainStyle } x-  | str == "\n" = ""-  | otherwise   = str-  where-    str = toPlain opt x "\n"--class ToString a where-    toLisp  :: Options -> a -> Builder-    toPlain :: Options -> a -> Builder--lineSep :: Options -> String-lineSep opt = interpret lsep-  where-    interpret s = read $ "\"" ++ s ++ "\""-    LineSeparator lsep = lineSeparator opt---- |------ >>> toLisp defaultOptions "fo\"o" ""--- "\"fo\\\"o\""--- >>> toPlain defaultOptions "foo" ""--- "foo"-instance ToString String where-    toLisp  opt = quote opt-    toPlain opt = replace '\n' (lineSep opt)---- |------ >>> toLisp defaultOptions ["foo", "bar", "ba\"z"] ""--- "(\"foo\" \"bar\" \"ba\\\"z\")"--- >>> toPlain defaultOptions ["foo", "bar", "baz"] ""--- "foo\nbar\nbaz"-instance ToString [String] where-    toLisp  opt = toSexp1 opt-    toPlain opt = inter '\n' . map (toPlain opt)---- |------ >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)]--- >>> toLisp defaultOptions inp ""--- "((1 2 3 4 \"foo\") (5 6 7 8 \"bar\"))"--- >>> toPlain defaultOptions inp ""--- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\""-instance ToString [((Int,Int,Int,Int),String)] where-    toLisp  opt = toSexp2 . map toS-      where-        toS x = ('(' :) . tupToString opt x . (')' :)-    toPlain opt = inter '\n' . map (tupToString opt)--instance ToString ((Int,Int,Int,Int),String) where-    toLisp  opt x = ('(' :) . tupToString opt x . (')' :)-    toPlain opt x = tupToString opt x--instance ToString ((Int,Int,Int,Int),[String]) where-    toLisp  opt (x,s) = ('(' :) . fourIntsToString opt x .-                        (' ' :) . toLisp opt s . (')' :)-    toPlain opt (x,s) = fourIntsToString opt x . ('\n' :) . toPlain opt s--instance ToString (String, (Int,Int,Int,Int),[String]) where-    toLisp  opt (s,x,y) = toSexp2 [toLisp opt s, ('(' :) . fourIntsToString opt x . (')' :), toLisp opt y]-    toPlain opt (s,x,y) = inter '\n' [toPlain opt s, fourIntsToString opt x, toPlain opt y]--toSexp1 :: Options -> [String] -> Builder-toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :)--toSexp2 :: [Builder] -> Builder-toSexp2 ss = ('(' :) . inter ' ' ss . (')' :)--fourIntsToString :: Options -> (Int,Int,Int,Int) -> Builder-fourIntsToString _ (a,b,c,d) = (show a ++) . (' ' :)-                             . (show b ++) . (' ' :)-                             . (show c ++) . (' ' :)-                             . (show d ++)--tupToString :: Options -> ((Int,Int,Int,Int),String) -> Builder-tupToString opt ((a,b,c,d),s) = (show a ++) . (' ' :)-                              . (show b ++) . (' ' :)-                              . (show c ++) . (' ' :)-                              . (show d ++) . (' ' :)-                              . quote opt s -- fixme: quote is not necessary--quote :: Options -> String -> Builder-quote opt str = ("\"" ++) .  (quote' str ++) . ("\"" ++)-  where-    lsep = lineSep opt-    quote' [] = []-    quote' (x:xs)-      | x == '\n' = lsep   ++ quote' xs-      | x == '\\' = "\\\\" ++ quote' xs-      | x == '"'  = "\\\"" ++ quote' xs-      | otherwise = x       : quote' xs---------------------------------------------------------------------- Empty result to be returned when no info can be gathered-emptyResult :: Monad m => Options -> m String-emptyResult opt = return $ convert opt ([] :: [String])---- Return an emptyResult when Nothing-whenFound :: (Monad m, ToString b) => Options -> m (Maybe a) -> (a -> b) -> m String-whenFound opt from f = maybe (emptyResult opt) (return . convert opt . f) =<< from---- Return an emptyResult when Nothing, inside a monad-whenFound' :: (Monad m, ToString b) => Options -> m (Maybe a) -> (a -> m b) -> m String-whenFound' opt from f = maybe (emptyResult opt) (\x -> do y <- f x ; return (convert opt y)) =<< from
− Language/Haskell/GhcMod/Cradle.hs 
@@ -1,109 +0,0 @@-module Language.Haskell.GhcMod.Cradle (-    findCradle-  , findCradle'-  , findCradleWithoutSandbox-  ) where--import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.GhcPkg--import Control.Applicative ((<$>))-import qualified Control.Exception as E-import Control.Exception.IOChoice ((||>))-import Control.Monad (filterM)-import Data.List (isSuffixOf)-import System.Directory (getCurrentDirectory, getDirectoryContents, doesFileExist)-import System.FilePath ((</>), takeDirectory)---------------------------------------------------------------------- | Finding 'Cradle'.---   Find a cabal file by tracing ancestor directories.---   Find a sandbox according to a cabal sandbox config---   in a cabal directory.-findCradle :: IO Cradle-findCradle = findCradle' =<< getCurrentDirectory--findCradle' :: FilePath -> IO Cradle-findCradle' dir = cabalCradle dir ||> sandboxCradle dir ||> plainCradle dir--cabalCradle :: FilePath -> IO Cradle-cabalCradle wdir = do-    (rdir,cfile) <- cabalDir wdir-    pkgDbStack <- getPackageDbStack rdir-    return Cradle {-        cradleCurrentDir = wdir-      , cradleRootDir    = rdir-      , cradleCabalFile  = Just cfile-      , cradlePkgDbStack = pkgDbStack-      }--sandboxCradle :: FilePath -> IO Cradle-sandboxCradle wdir = do-    rdir <- getSandboxDir wdir-    pkgDbStack <- getPackageDbStack rdir-    return Cradle {-        cradleCurrentDir = wdir-      , cradleRootDir    = rdir-      , cradleCabalFile  = Nothing-      , cradlePkgDbStack = pkgDbStack-      }--plainCradle :: FilePath -> IO Cradle-plainCradle wdir = return Cradle {-        cradleCurrentDir = wdir-      , cradleRootDir    = wdir-      , cradleCabalFile  = Nothing-      , cradlePkgDbStack = [GlobalDb, UserDb]-      }---- Just for testing-findCradleWithoutSandbox :: IO Cradle-findCradleWithoutSandbox = do-    cradle <- findCradle-    return cradle { cradlePkgDbStack = [GlobalDb]} -- FIXME--------------------------------------------------------------------cabalSuffix :: String-cabalSuffix = ".cabal"--cabalSuffixLength :: Int-cabalSuffixLength = length cabalSuffix---- Finding a Cabal file up to the root directory--- Input: a directly to investigate--- Output: (the path to the directory containing a Cabal file---         ,the path to the Cabal file)-cabalDir :: FilePath -> IO (FilePath,FilePath)-cabalDir dir = do-    cnts <- getCabalFiles dir-    case cnts of-        [] | dir' == dir -> E.throwIO $ userError "cabal files not found"-           | otherwise   -> cabalDir dir'-        cfile:_          -> return (dir,dir </> cfile)-  where-    dir' = takeDirectory dir--getCabalFiles :: FilePath -> IO [FilePath]-getCabalFiles dir = getFiles >>= filterM doesCabalFileExist-  where-    isCabal name = cabalSuffix `isSuffixOf` name-                && length name > cabalSuffixLength-    getFiles = filter isCabal <$> getDirectoryContents dir-    doesCabalFileExist file = doesFileExist $ dir </> file--------------------------------------------------------------------getSandboxDir :: FilePath -> IO FilePath-getSandboxDir dir = do-    exist <- doesFileExist sfile-    if exist then-        return dir-      else if dir == dir' then-        E.throwIO $ userError "sandbox not found"-      else-        getSandboxDir dir'-  where-    sfile = dir </> "cabal.sandbox.config"-    dir' = takeDirectory dir
− Language/Haskell/GhcMod/Debug.hs 
@@ -1,41 +0,0 @@-module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo) where--import Control.Applicative ((<$>))-import Data.List (intercalate)-import Data.Maybe (isJust, fromJust)-import Language.Haskell.GhcMod.Convert-import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Internal---------------------------------------------------------------------- | Obtaining debug information.-debugInfo :: IOish m => GhcModT m String-debugInfo = cradle >>= \c -> convert' =<< do-    CompilerOptions gopts incDir pkgs <--        if isJust $ cradleCabalFile c then-            fromCabalFile c ||> simpleCompilerOption-          else-            simpleCompilerOption-    return [-        "Root directory:      " ++ cradleRootDir c-      , "Current directory:   " ++ cradleCurrentDir c-      , "Cabal file:          " ++ show (cradleCabalFile c)-      , "GHC options:         " ++ unwords gopts-      , "Include directories: " ++ unwords incDir-      , "Dependent packages:  " ++ intercalate ", " (map showPkg pkgs)-      , "System libraries:    " ++ ghcLibDir-      ]-  where-    simpleCompilerOption = options >>= \op ->-        return $ CompilerOptions (ghcUserOptions op) [] []-    fromCabalFile c = options >>= \opts -> do-        pkgDesc <- parseCabalFile c $ fromJust $ cradleCabalFile c-        getCompilerOptions (ghcUserOptions opts) c pkgDesc---------------------------------------------------------------------- | Obtaining root information.-rootInfo :: IOish m => GhcModT m String-rootInfo = convert' =<< cradleRootDir <$> cradle
− Language/Haskell/GhcMod/Doc.hs 
@@ -1,21 +0,0 @@-module Language.Haskell.GhcMod.Doc where--import GHC (DynFlags, GhcMonad)-import qualified GHC as G-import Language.Haskell.GhcMod.Gap (withStyle, showDocWith)-import Outputable (SDoc, PprStyle, mkUserStyle, Depth(AllTheWay), neverQualify)-import Pretty (Mode(..))--showPage :: DynFlags -> PprStyle -> SDoc -> String-showPage dflag style = showDocWith dflag PageMode . withStyle dflag style--showOneLine :: DynFlags -> PprStyle -> SDoc -> String-showOneLine dflag style = showDocWith dflag OneLineMode . withStyle dflag style--getStyle :: GhcMonad m => m PprStyle-getStyle = do-    unqual <- G.getPrintUnqual-    return $ mkUserStyle unqual AllTheWay--styleUnqualified :: PprStyle-styleUnqualified = mkUserStyle neverQualify AllTheWay
− Language/Haskell/GhcMod/DynFlags.hs 
@@ -1,121 +0,0 @@-{-# LANGUAGE CPP #-}--module Language.Haskell.GhcMod.DynFlags where--import Control.Applicative ((<$>))-import Control.Monad (void)-import GHC (DynFlags(..), GhcMode(..), GhcLink(..), HscTarget(..))-import qualified GHC as G-import GHC.Paths (libdir)-import GhcMonad-import qualified Language.Haskell.GhcMod.Gap as Gap-import Language.Haskell.GhcMod.Types-import System.IO.Unsafe (unsafePerformIO)--data Build = CabalPkg | SingleFile deriving Eq--setEmptyLogger :: DynFlags -> DynFlags-setEmptyLogger df = Gap.setLogAction df $ \_ _ _ _ _ -> return ()---- * Fast--- * Friendly to foreign export--- * Not friendly to -XTemplateHaskell and -XPatternSynonyms--- * Uses little memory-setModeSimple :: DynFlags -> DynFlags-setModeSimple df = df {-    ghcMode   = CompManager-  , ghcLink   = NoLink-  , hscTarget = HscNothing-  , optLevel  = 0-  }---- * Slow--- * Not friendly to foreign export--- * Friendly to -XTemplateHaskell and -XPatternSynonyms--- * Uses lots of memory-setModeIntelligent :: DynFlags -> DynFlags-setModeIntelligent df = df {-    ghcMode   = CompManager-  , ghcLink   = LinkInMemory-  , hscTarget = HscInterpreted-  , optLevel  = 0-  }--setIncludeDirs :: [IncludeDir] -> DynFlags -> DynFlags-setIncludeDirs idirs df = df { importPaths = idirs }--setBuildEnv :: Build -> DynFlags -> DynFlags-setBuildEnv build = setHideAllPackages build . setCabalPackage build---- | With ghc-7.8 this option simply makes GHC print a message suggesting users--- add hiddend packages to the build-depends field in their cabal file when the--- user tries to import a module form a hidden package.-setCabalPackage :: Build -> DynFlags -> DynFlags-setCabalPackage CabalPkg df = Gap.setCabalPkg df-setCabalPackage _ df = df---- | Enable hiding of all package not explicitly exposed (like Cabal does)-setHideAllPackages :: Build -> DynFlags -> DynFlags-setHideAllPackages CabalPkg df = Gap.setHideAllPackages df-setHideAllPackages _ df = df---- | Parse command line ghc options and add them to the 'DynFlags' passed-addCmdOpts :: GhcMonad m => [GHCOption] -> DynFlags -> m DynFlags-addCmdOpts cmdOpts df =-    tfst <$> G.parseDynamicFlags df (map G.noLoc cmdOpts)-  where-    tfst (a,_,_) = a---------------------------------------------------------------------- | Return the 'DynFlags' currently in use in the GHC session.-getDynamicFlags :: IO DynFlags-getDynamicFlags = G.runGhc (Just libdir) G.getSessionDynFlags--withDynFlags :: GhcMonad m-             => (DynFlags -> DynFlags)-             -> m a-             -> m a-withDynFlags setFlags body = G.gbracket setup teardown (\_ -> body)-  where-    setup = do-        dflags <- G.getSessionDynFlags-        void $ G.setSessionDynFlags (setFlags dflags)-        return dflags-    teardown = void . G.setSessionDynFlags--withCmdFlags :: GhcMonad m => [GHCOption] -> m a -> m a-withCmdFlags flags body = G.gbracket setup teardown (\_ -> body)-  where-    setup = do-        dflags <- G.getSessionDynFlags-        void $ G.setSessionDynFlags =<< addCmdOpts flags dflags-        return dflags-    teardown = void . G.setSessionDynFlags---------------------------------------------------------------------- | Set 'DynFlags' equivalent to "-w:".-setNoWarningFlags :: DynFlags -> DynFlags-setNoWarningFlags df = df { warningFlags = Gap.emptyWarnFlags}---- | Set 'DynFlags' equivalent to "-Wall".-setAllWarningFlags :: DynFlags -> DynFlags-setAllWarningFlags df = df { warningFlags = allWarningFlags }--allWarningFlags :: Gap.WarnFlags-allWarningFlags = unsafePerformIO $-    G.runGhc (Just libdir) $ do-        df <- G.getSessionDynFlags-        df' <- addCmdOpts ["-Wall"] df-        return $ G.warningFlags df'---------------------------------------------------------------------- | Set 'DynFlags' equivalent to "-fno-max-relevant-bindings".-setNoMaxRelevantBindings :: DynFlags -> DynFlags-#if __GLASGOW_HASKELL__ >= 708-setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing }-#else-setNoMaxRelevantBindings = id-#endif
− Language/Haskell/GhcMod/Error.hs 
@@ -1,41 +0,0 @@-{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-}-module Language.Haskell.GhcMod.Error (-    GhcModError(..)-  , modifyError-  , modifyError'-  , tryFix-  , module Control.Monad.Error-  , module Exception-  ) where--import Control.Monad.Error (MonadError(..), Error(..))-import Exception--data GhcModError = GMENoMsg-                 -- ^ Unknown error-                 | GMEString String-                 -- ^ Some Error with a message. These are produced mostly by-                 -- 'fail' calls on GhcModT.-                 | GMECabalConfigure GhcModError-                 -- ^ Configuring a cabal project failed.-                 | GMECabalFlags GhcModError-                 -- ^ Retrieval of the cabal configuration flags failed.-                 | GMEProcess [String] GhcModError-                 -- ^ Launching an operating system process failed. The first-                 -- field is the command.-                   deriving (Eq,Show)--instance Error GhcModError where-    noMsg = GMENoMsg-    strMsg = GMEString--modifyError :: MonadError e m => (e -> e) -> m a -> m a-modifyError f action = action `catchError` \e -> throwError $ f e--infixr 0 `modifyError'`-modifyError' :: MonadError e m => m a -> (e -> e) -> m a-modifyError' = flip modifyError--tryFix :: MonadError e m => m a -> (e -> m ()) -> m a-tryFix action fix = do-  action `catchError` \e -> fix e >> action
− Language/Haskell/GhcMod/FillSig.hs 
@@ -1,484 +0,0 @@-{-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies #-}-{-# LANGUAGE FlexibleInstances #-}--module Language.Haskell.GhcMod.FillSig (-    sig-  , refine-  , auto-  ) where--import Data.Char (isSymbol)-import Data.Function (on)-import Data.List (find, nub, sortBy)-import qualified Data.Map as M-import Data.Maybe (isJust, catMaybes)-import Exception (ghandle, SomeException(..))-import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags,-            SrcSpan, Type, GenLocated(L))-import qualified GHC as G-import qualified Name as G-import qualified Language.Haskell.GhcMod.Gap as Gap-import Language.Haskell.GhcMod.Convert-import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.SrcUtils-import Language.Haskell.GhcMod.Types-import Outputable (PprStyle)-import qualified Type as Ty-import qualified HsBinds as Ty-import qualified Class as Ty-import qualified Var as Ty-import qualified HsPat as Ty-import qualified Language.Haskell.Exts.Annotated as HE-import Djinn.GHC--------------------------------------------------------------------- INTIAL CODE FROM FUNCTION OR INSTANCE SIGNATURE--------------------------------------------------------------------- Possible signatures we can find: function or instance-data SigInfo-    = Signature SrcSpan [G.RdrName] (G.HsType G.RdrName)-    | InstanceDecl SrcSpan G.Class-    | TyFamDecl SrcSpan G.RdrName TyFamType {- True if closed -} [G.RdrName]---- Signature for fallback operation via haskell-src-exts-data HESigInfo-    = HESignature HE.SrcSpan [HE.Name HE.SrcSpanInfo] (HE.Type HE.SrcSpanInfo)-    | HEFamSignature-          HE.SrcSpan-          TyFamType-          (HE.Name HE.SrcSpanInfo)-          [HE.Name HE.SrcSpanInfo]--data TyFamType = Closed | Open | Data-initialTyFamString :: TyFamType -> (String, String)-initialTyFamString Closed = ("instance", "")-initialTyFamString Open   = ("function", "type instance ")-initialTyFamString Data   = ("function", "data instance ")---- | Create a initial body from a signature.-sig :: IOish m-    => FilePath     -- ^ A target file.-    -> Int          -- ^ Line number.-    -> Int          -- ^ Column number.-    -> GhcModT m String-sig file lineNo colNo = ghandle handler body-  where-    body = inModuleContext file $ \dflag style -> do-        opt <- options-        modSum <- Gap.fileModSummary file-        whenFound opt (getSignature modSum lineNo colNo) $ \s -> case s of-          Signature loc names ty ->-            ("function", fourInts loc, map (initialBody dflag style ty) names)-          InstanceDecl loc cls ->-             ("instance", fourInts loc, map (\x -> initialBody dflag style (G.idType x) x)-                                            (Ty.classMethods cls))-          TyFamDecl loc name flavour vars ->-            let (rTy, initial) = initialTyFamString flavour-             in (rTy, fourInts loc, [initial ++ initialFamBody dflag style name vars])--    handler (SomeException _) = do-      opt <- options-      -- Code cannot be parsed by ghc module-      -- Fallback: try to get information via haskell-src-exts-      whenFound opt (getSignatureFromHE file lineNo colNo) $ \x -> case x of-        HESignature loc names ty ->-          ("function", fourIntsHE loc, map (initialBody undefined undefined ty) names)-        HEFamSignature loc flavour name vars ->-          let (rTy, initial) = initialTyFamString flavour-           in (rTy, fourIntsHE loc, [initial ++ initialFamBody undefined undefined name vars])--------------------------------------------------------------------- a. Code for getting the information---- Get signature from ghc parsing and typechecking-getSignature :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SigInfo)-getSignature modSum lineNo colNo = do-    p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum-    -- Inspect the parse tree to find the signature-    case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsDecl G.RdrName] of-      [L loc (G.SigD (Ty.TypeSig names (L _ ty)))] ->-        -- We found a type signature-        return $ Just $ Signature loc (map G.unLoc names) ty-      [L _ (G.InstD _)] -> do-        -- We found an instance declaration-        TypecheckedModule{tm_renamed_source = Just tcs-                         ,tm_checked_module_info = minfo} <- G.typecheckModule p-        let lst = listifyRenamedSpans tcs (lineNo, colNo)-        case Gap.getClass lst of-            Just (clsName,loc) -> obtainClassInfo minfo clsName loc-            _                  -> return Nothing-#if __GLASGOW_HASKELL__ >= 708-      [L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars) _)))] -> do-#elif __GLASGOW_HASKELL__ >= 706-      [L loc (G.TyClD (G.TyFamily info (L _ name) (G.HsQTvs _ vars) _))] -> do-#else-      [L loc (G.TyClD (G.TyFamily info (L _ name) vars _))] -> do-#endif-#if __GLASGOW_HASKELL__ >= 708-        let flavour = case info of-                        G.ClosedTypeFamily _ -> Closed-                        G.OpenTypeFamily     -> Open-                        G.DataFamily         -> Data-#else-        let flavour = case info of  -- Closed type families where introduced in GHC 7.8-                        G.TypeFamily -> Open-                        G.DataFamily -> Data-#endif-#if __GLASGOW_HASKELL__ >= 706-            getTyFamVarName x = case x of-                L _ (G.UserTyVar n)     -> n-                L _ (G.KindedTyVar n _) -> n-#else-            getTyFamVarName x = case x of  -- In GHC 7.4, HsTyVarBndr's have an extra arg-                L _ (G.UserTyVar n _)     -> n-                L _ (G.KindedTyVar n _ _) -> n-#endif-         in return $ Just (TyFamDecl loc name flavour $ map getTyFamVarName vars)-      _ -> return Nothing-  where obtainClassInfo :: GhcMonad m => G.ModuleInfo -> G.Name -> SrcSpan -> m (Maybe SigInfo)-        obtainClassInfo minfo clsName loc = do-          tyThing <- G.modInfoLookupName minfo clsName-          return $ do Ty.ATyCon clsCon <- tyThing  -- In Maybe-                      cls <- G.tyConClass_maybe clsCon-                      return $ InstanceDecl loc cls---- Get signature from haskell-src-exts-getSignatureFromHE :: GhcMonad m => FilePath -> Int -> Int -> m (Maybe HESigInfo)-getSignatureFromHE file lineNo colNo = do-  presult <- liftIO $ HE.parseFile file-  return $ case presult of-             HE.ParseOk (HE.Module _ _ _ _ mdecls) -> do-               decl <- find (typeSigInRangeHE lineNo colNo) mdecls-               case decl of-                 HE.TypeSig (HE.SrcSpanInfo s _) names ty ->-                     return $ HESignature s names ty--                 HE.TypeFamDecl (HE.SrcSpanInfo s _) declHead _ ->-                   let (name, tys) = dHeadTyVars declHead in-                   return $ HEFamSignature s Open name (map cleanTyVarBind tys)--                 HE.DataFamDecl (HE.SrcSpanInfo s _) _ declHead _ ->-                   let (name, tys) = dHeadTyVars declHead in-                   return $ HEFamSignature s Open name (map cleanTyVarBind tys)-                 _ -> fail ""-             _ -> Nothing-  where cleanTyVarBind (HE.KindedVar _ n _) = n-        cleanTyVarBind (HE.UnkindedVar _ n) = n--#if MIN_VERSION_haskell_src_exts(1,16,0)-        dHeadTyVars :: HE.DeclHead l -> (HE.Name l, [HE.TyVarBind l])-        dHeadTyVars (HE.DHead _ name) = (name, [])-        dHeadTyVars (HE.DHApp _ r ty) = (++[ty]) `fmap` (dHeadTyVars r)-        dHeadTyVars (HE.DHInfix _ ty name) = (name, [ty])-        dHeadTyVars (HE.DHParen _ r) = dHeadTyVars r-#else-        dHeadTyVars :: HE.DeclHead l -> (HE.Name l, [HE.TyVarBind l])-        dHeadTyVars (HE.DHead _ n tys) = (n, tys)-#endif--------------------------------------------------------------------- b. Code for generating initial code---- A list of function arguments, and whether they are functions or normal--- arguments is built from either a function signature or an instance signature-data FnArg = FnArgFunction | FnArgNormal | FnExplicitName String--initialBody :: FnArgsInfo ty name => DynFlags -> PprStyle -> ty -> name -> String-initialBody dflag style ty name =-    initialBody' (getFnName dflag style name) (getFnArgs ty)--initialBody' :: String -> [FnArg] -> String-initialBody' fname args =-    initialHead fname args ++ " = " ++ n ++ "_body"- where n = if isSymbolName fname then "" else '_':fname--initialFamBody :: FnArgsInfo ty name-               => DynFlags -> PprStyle -> name -> [name] -> String-initialFamBody dflag style name args =-    initialHead fnName fnArgs ++ " = ()"- where fnName = getFnName dflag style name-       fnArgs = map (FnExplicitName . getFnName dflag style) args--initialHead :: String -> [FnArg] -> String-initialHead fname args =-  case initialBodyArgs args infiniteVars infiniteFns of-    []      -> fname-    arglist -> if isSymbolName fname-               then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)-               else fname ++ " " ++ unwords arglist--initialBodyArgs :: [FnArg] -> [String] -> [String] -> [String]-initialBodyArgs [] _ _ = []-initialBodyArgs (FnArgFunction:xs) vs (f:fs) = f : initialBodyArgs xs vs fs-initialBodyArgs (FnArgNormal:xs)   (v:vs) fs = v : initialBodyArgs xs vs fs-initialBodyArgs (FnExplicitName n:xs)  vs fs = n : initialBodyArgs xs vs fs-initialBodyArgs _                  _      _  =-    error "initialBodyArgs: This should never happen" -- Lists are infinite--initialHead1 :: String -> [FnArg] -> [String] -> String-initialHead1 fname args elts =-  case initialBodyArgs1 args elts of-    []      -> fname-    arglist -> if isSymbolName fname-               then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)-               else fname ++ " " ++ unwords arglist--initialBodyArgs1 :: [FnArg] -> [String] -> [String]-initialBodyArgs1 args elts = take (length args) elts---- Getting the initial body of function and instances differ--- This is because for functions we only use the parsed file--- (so the full file doesn't have to be type correct)--- but for instances we need to get information about the class--class FnArgsInfo ty name | ty -> name, name -> ty where-  getFnName :: DynFlags -> PprStyle -> name -> String-  getFnArgs :: ty -> [FnArg]--instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where-  getFnName dflag style name = showOccName dflag style $ Gap.occName name-  getFnArgs (G.HsForAllTy _ _ _ (L _ iTy))  = getFnArgs iTy-  getFnArgs (G.HsParTy (L _ iTy))           = getFnArgs iTy-  getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) =-      (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy-    where fnarg ty = case ty of-              (G.HsForAllTy _ _ _ (L _ iTy)) -> fnarg iTy-              (G.HsParTy (L _ iTy))          -> fnarg iTy-              (G.HsFunTy _ _)                -> True-              _                              -> False-  getFnArgs _ = []--instance FnArgsInfo (HE.Type HE.SrcSpanInfo) (HE.Name HE.SrcSpanInfo) where-  getFnName _ _ (HE.Ident  _ s) = s-  getFnName _ _ (HE.Symbol _ s) = s-  getFnArgs (HE.TyForall _ _ _ iTy) = getFnArgs iTy-  getFnArgs (HE.TyParen _ iTy)      = getFnArgs iTy-  getFnArgs (HE.TyFun _ lTy rTy)    =-      (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy-    where fnarg ty = case ty of-              (HE.TyForall _ _ _ iTy) -> fnarg iTy-              (HE.TyParen _ iTy)      -> fnarg iTy-              (HE.TyFun _ _ _)        -> True-              _                       -> False-  getFnArgs _ = []--instance FnArgsInfo Type Id where-  getFnName dflag style method = showOccName dflag style $ G.getOccName method-  getFnArgs = getFnArgs' . Ty.dropForAlls-    where getFnArgs' ty | Just (lTy,rTy) <- Ty.splitFunTy_maybe ty =-            maybe (if Ty.isPredTy lTy then getFnArgs' rTy else FnArgNormal:getFnArgs' rTy)-                  (\_ -> FnArgFunction:getFnArgs' rTy)-                  $ Ty.splitFunTy_maybe lTy--          getFnArgs' ty | Just (_,iTy) <- Ty.splitForAllTy_maybe ty =-              getFnArgs' iTy--          getFnArgs' _ = []---- Infinite supply of variable and function variable names-infiniteVars, infiniteFns :: [String]-infiniteVars = infiniteSupply ["x","y","z","t","u","v","w"]-infiniteFns  = infiniteSupply ["f","g","h"]-infiniteSupply :: [String] -> [String]-infiniteSupply initialSupply =-    initialSupply ++ concatMap (\n -> map (\v -> v ++ show n) initialSupply)-                               ([1 .. ] :: [Integer])---- Check whether a String is a symbol name-isSymbolName :: String -> Bool-isSymbolName (c:_) = c `elem` "!#$%&*+./<=>?@\\^|-~" || isSymbol c-isSymbolName []    = error "This should never happen"---------------------------------------------------------------------- REWRITE A HOLE / UNDEFINED VIA A FUNCTION-------------------------------------------------------------------refine :: IOish m-       => FilePath     -- ^ A target file.-       -> Int          -- ^ Line number.-       -> Int          -- ^ Column number.-       -> Expression   -- ^ A Haskell expression.-       -> GhcModT m String-refine file lineNo colNo expr = ghandle handler body-  where-    body = inModuleContext file $ \dflag style -> do-        opt <- options-        modSum <- Gap.fileModSummary file-        p <- G.parseModule modSum-        tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p-        ety <- G.exprType expr-        whenFound opt (findVar dflag style tcm tcs lineNo colNo) $-          \(loc, name, rty, paren) ->-              let eArgs = getFnArgs ety-                  rArgs = getFnArgs rty-                  diffArgs' = length eArgs - length rArgs-                  diffArgs  = if diffArgs' < 0 then 0 else diffArgs'-                  iArgs = take diffArgs eArgs-                  text = initialHead1 expr iArgs (infinitePrefixSupply name)-               in (fourInts loc, doParen paren text)--    handler (SomeException _) = emptyResult =<< options---- Look for the variable in the specified position-findVar :: GhcMonad m => DynFlags -> PprStyle-                      -> G.TypecheckedModule -> G.TypecheckedSource-                      -> Int -> Int -> m (Maybe (SrcSpan, String, Type, Bool))-findVar dflag style tcm tcs lineNo colNo =-  let lst = sortBy (cmp `on` G.getLoc) $-                listifySpans tcs (lineNo, colNo) :: [G.LHsExpr Id]-  in case lst of-      e@(L _ (G.HsVar i)):others ->-        do tyInfo <- Gap.getType tcm e-           let name = getFnName dflag style i-           if (name == "undefined" || head name == '_') && isJust tyInfo-              then let Just (s,t) = tyInfo-                       b = case others of  -- If inside an App, we need-                                           -- parenthesis-                             [] -> False-                             L _ (G.HsApp (L _ a1) (L _ a2)):_ ->-                               isSearchedVar i a1 || isSearchedVar i a2-                             _  -> False-                    in return $ Just (s, name, t, b)-              else return Nothing-      _ -> return Nothing--infinitePrefixSupply :: String -> [String]-infinitePrefixSupply "undefined" = repeat "undefined"-infinitePrefixSupply p = map (\n -> p ++ "_" ++ show n) ([1 ..] :: [Integer])--doParen :: Bool -> String -> String-doParen False s = s-doParen True  s = if ' ' `elem` s then '(':s ++ ")" else s--isSearchedVar :: Id -> G.HsExpr Id -> Bool-isSearchedVar i (G.HsVar i2) = i == i2-isSearchedVar _ _ = False---------------------------------------------------------------------- REFINE AUTOMATICALLY-------------------------------------------------------------------auto :: IOish m-     => FilePath     -- ^ A target file.-     -> Int          -- ^ Line number.-     -> Int          -- ^ Column number.-     -> GhcModT m String-auto file lineNo colNo = ghandle handler body-  where-    body = inModuleContext file $ \dflag style -> do-        opt <- options-        modSum <- Gap.fileModSummary file-        p <- G.parseModule modSum-        tcm@TypecheckedModule {-                 tm_typechecked_source = tcs-               , tm_checked_module_info = minfo-               } <- G.typecheckModule p-        whenFound' opt (findVar dflag style tcm tcs lineNo colNo) $ \(loc, _name, rty, paren) -> do-          topLevel <- getEverythingInTopLevel minfo-          let (f,pats) = getPatsForVariable tcs (lineNo,colNo)-              -- Remove self function to prevent recursion, and id to trim-              -- cases-              filterFn (n,_) = let funName = G.getOccString n-                                   recName = G.getOccString (G.getName f)-                               in funName `notElem` recName:notWantedFuns-              -- Find without using other functions in top-level-              localBnds = M.unions $-                  map (\(L _ pat) -> getBindingsForPat pat) pats-              lbn = filter filterFn (M.toList localBnds)-          djinnsEmpty <- djinn True (Just minfo) lbn rty (Max 10) 100000-          let -- Find with the entire top-level-              almostEnv = M.toList $ M.union localBnds topLevel-              env = filter filterFn almostEnv-          djinns <- djinn True (Just minfo) env rty (Max 10) 100000-          return ( fourInts loc-                 , map (doParen paren) $ nub (djinnsEmpty ++ djinns))--    handler (SomeException _) = emptyResult =<< options---- Functions we do not want in completions-notWantedFuns :: [String]-notWantedFuns = ["id", "asTypeOf", "const"]---- Get all things defined in top-level-getEverythingInTopLevel :: GhcMonad m => G.ModuleInfo -> m (M.Map G.Name Type)-getEverythingInTopLevel m = do-  let modInfo  = tyThingsToInfo (G.modInfoTyThings m)-      topNames = G.modInfoTopLevelScope m-  case topNames of-    Just topNames' -> do topThings <- mapM G.lookupGlobalName topNames'-                         let topThings' = catMaybes topThings-                             topInfo    = tyThingsToInfo topThings'-                         return $ M.union modInfo topInfo-    Nothing -> return modInfo--tyThingsToInfo :: [Ty.TyThing] -> M.Map G.Name Type-tyThingsToInfo [] = M.empty-tyThingsToInfo (G.AnId i : xs) =-    M.insert (G.getName i) (Ty.varType i) (tyThingsToInfo xs)--- Getting information about constructors is not needed--- because they will be added by djinn-ghc when traversing types--- #if __GLASGOW_HASKELL__ >= 708--- tyThingToInfo (G.AConLike (G.RealDataCon con)) = return [(Ty.dataConName con, Ty.dataConUserType con)]--- #else--- tyThingToInfo (G.AConLike con) = return [(Ty.dataConName con, Ty.dataConUserType con)]--- #endif-tyThingsToInfo (_:xs) = tyThingsToInfo xs---- Find the Id of the function and the pattern where the hole is located-getPatsForVariable :: G.TypecheckedSource -> (Int,Int) -> (Id, [Ty.LPat Id])-getPatsForVariable tcs (lineNo, colNo) =-  let (L _ bnd:_) = sortBy (cmp `on` G.getLoc) $-                      listifySpans tcs (lineNo, colNo) :: [G.LHsBind Id]-   in case bnd of-        G.PatBind { Ty.pat_lhs = L ploc pat }  -> case pat of-          Ty.ConPatIn (L _ i) _ -> (i, [L ploc pat])-          _                     -> (error "This should never happen", [])-        G.FunBind { Ty.fun_id = L _ funId } ->-          let m = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo)-#if __GLASGOW_HASKELL__ >= 708-                    :: [G.LMatch Id (G.LHsExpr Id)]-#else-                    :: [G.LMatch Id]-#endif-              (L _ (G.Match pats _ _):_) = m-           in (funId, pats)-        _ -> (error "This should never happen", [])--getBindingsForPat :: Ty.Pat Id -> M.Map G.Name Type-getBindingsForPat (Ty.VarPat i) = M.singleton (G.getName i) (Ty.varType i)-getBindingsForPat (Ty.LazyPat (L _ l)) = getBindingsForPat l-getBindingsForPat (Ty.BangPat (L _ b)) = getBindingsForPat b-getBindingsForPat (Ty.AsPat (L _ a) (L _ i)) =-    M.insert (G.getName a) (Ty.varType a) (getBindingsForPat i)-#if __GLASGOW_HASKELL__ >= 708-getBindingsForPat (Ty.ListPat  l _ _) =-    M.unions $ map (\(L _ i) -> getBindingsForPat i) l-#else-getBindingsForPat (Ty.ListPat  l _)   =-    M.unions $ map (\(L _ i) -> getBindingsForPat i) l-#endif-getBindingsForPat (Ty.TuplePat l _ _) =-    M.unions $ map (\(L _ i) -> getBindingsForPat i) l-getBindingsForPat (Ty.PArrPat  l _)   =-    M.unions $ map (\(L _ i) -> getBindingsForPat i) l-getBindingsForPat (Ty.ViewPat _ (L _ i) _) = getBindingsForPat i-getBindingsForPat (Ty.SigPatIn  (L _ i) _) = getBindingsForPat i-getBindingsForPat (Ty.SigPatOut (L _ i) _) = getBindingsForPat i-getBindingsForPat (Ty.ConPatIn (L _ i) d) =-    M.insert (G.getName i) (Ty.varType i) (getBindingsForRecPat d)-getBindingsForPat (Ty.ConPatOut { Ty.pat_args = d }) = getBindingsForRecPat d-getBindingsForPat _ = M.empty--getBindingsForRecPat :: Ty.HsConPatDetails Id -> M.Map G.Name Type-getBindingsForRecPat (Ty.PrefixCon args) =-    M.unions $ map (\(L _ i) -> getBindingsForPat i) args-getBindingsForRecPat (Ty.InfixCon (L _ a1) (L _ a2)) =-    M.union (getBindingsForPat a1) (getBindingsForPat a2)-getBindingsForRecPat (Ty.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) =-    getBindingsForRecFields fields- where getBindingsForRecFields [] = M.empty-       getBindingsForRecFields (Ty.HsRecField {Ty.hsRecFieldArg = (L _ a)}:fs) =-         M.union (getBindingsForPat a) (getBindingsForRecFields fs)
− Language/Haskell/GhcMod/Find.hs 
@@ -1,207 +0,0 @@-{-# LANGUAGE CPP #-}--module Language.Haskell.GhcMod.Find-#ifndef SPEC-  (-    Symbol-  , SymbolDb-  , loadSymbolDb-  , lookupSymbol-  , dumpSymbol-  , findSymbol-  , lookupSym-  )-#endif-  where--import Config (cProjectVersion,cTargetPlatformString)-import Control.Applicative ((<$>))-import Control.Monad (when, void)-import Control.Monad.Error.Class-import Data.Function (on)-import Data.List (groupBy, sort)-import Data.List.Split (splitOn)-import Data.Maybe (fromMaybe)-import DynFlags (DynFlags(..), systemPackageConfig)-import Exception (handleIO)-import qualified GHC as G-import Language.Haskell.GhcMod.Convert-import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.Utils-import Language.Haskell.GhcMod.Types-import Name (getOccString)-import System.Directory (doesDirectoryExist, getAppUserDataDirectory, doesFileExist, getModificationTime)-import System.FilePath ((</>), takeDirectory)-import System.IO-import System.Environment--#ifndef MIN_VERSION_containers-#define MIN_VERSION_containers(x,y,z) 1-#endif--#if MIN_VERSION_containers(0,5,0)-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as M-#else-import Data.Map (Map)-import qualified Data.Map as M-#endif---------------------------------------------------------------------- | Type of function and operation names.-type Symbol = String--- | Database from 'Symbol' to \['ModuleString'\].-newtype SymbolDb = SymbolDb (Map Symbol [ModuleString])-    deriving (Show)---------------------------------------------------------------------- | When introducing incompatible changes to the 'symbolCache' file format--- increment this version number.-symbolCacheVersion :: Integer-symbolCacheVersion = 0---- | Filename of the symbol table cache file.-symbolCache :: String-symbolCache = "ghc-mod-"++ show symbolCacheVersion ++".cache"--packageCache :: String-packageCache = "package.cache"--packageConfDir :: String-packageConfDir = "package.conf.d"---------------------------------------------------------------------- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]---   which will be concatenated. 'loadSymbolDb' is called internally.-findSymbol :: IOish m => Symbol -> GhcModT m String-findSymbol sym = loadSymbolDb >>= lookupSymbol sym---- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]---   which will be concatenated.-lookupSymbol :: IOish m => Symbol -> SymbolDb -> GhcModT m String-lookupSymbol sym db = convert' $ lookupSym sym db--lookupSym :: Symbol -> SymbolDb -> [ModuleString]-lookupSym sym (SymbolDb db) = fromMaybe [] $ M.lookup sym db--------------------------------------------------------------------- | Loading a file and creates 'SymbolDb'.-loadSymbolDb :: (IOish m, MonadError GhcModError m) => m SymbolDb-loadSymbolDb = SymbolDb <$> readSymbolDb---- | Returns the path to the currently running ghc-mod executable. With ghc<7.6--- this is a guess but >=7.6 uses 'getExecutablePath'.-ghcModExecutable :: IO FilePath-#ifndef SPEC-ghcModExecutable = do-    dir <- getExecutablePath'-    return $ dir </> "ghc-mod"-#else-ghcModExecutable = do _ <- getExecutablePath' -- get rid of unused warning when-                                              -- compiling spec-                      return "dist/build/ghc-mod/ghc-mod"-#endif- where-    getExecutablePath' :: IO FilePath-# if __GLASGOW_HASKELL__ >= 706-    getExecutablePath' = takeDirectory <$> getExecutablePath-# else-    getExecutablePath' = return ""-# endif--readSymbolDb :: (IOish m, MonadError GhcModError m) => m (Map Symbol [ModuleString])-readSymbolDb = do-    ghcMod <- liftIO ghcModExecutable-    file <- chop <$> readProcess' ghcMod ["dumpsym"]-    M.fromAscList . map conv . lines <$> liftIO (readFile file)-  where-    conv :: String -> (Symbol,[ModuleString])-    conv = read-    chop "" = ""-    chop xs = init xs--------------------------------------------------------------------- used 'ghc-mod dumpsym'--getSymbolCachePath :: IOish m => GhcModT m FilePath-getSymbolCachePath = do-    u:_ <- filter (/= GlobalDb) . cradlePkgDbStack <$> cradle-    Just db <- (liftIO . flip resolvePackageDb u) =<< G.getSessionDynFlags-    return db-  `catchError` const (fail "Couldn't find non-global package database for symbol cache")---- | Dumping a set of ('Symbol',\['ModuleString'\]) to a file---   if the file does not exist or is invalid.---   The file name is printed.--dumpSymbol :: IOish m => GhcModT m String-dumpSymbol = do-    dir <- getSymbolCachePath-    let cache = dir </> symbolCache-        pkgdb = dir </> packageCache--    create <- liftIO $ cache `isNewerThan` pkgdb-    when create $ (liftIO . writeSymbolCache cache) =<< getSymbolTable-    return $ unlines [cache]--writeSymbolCache :: FilePath-                 -> [(Symbol,[ModuleString])]-                 -> IO ()-writeSymbolCache cache sm =-  void . withFile cache WriteMode $ \hdl ->-      mapM (hPrint hdl) sm--isNewerThan :: FilePath -> FilePath -> IO Bool-isNewerThan ref file = do-    exist <- doesFileExist ref-    if not exist then-        return True-      else do-        tRef <- getModificationTime ref-        tFile <- getModificationTime file-        return $ tRef <= tFile -- including equal just in case---- | Browsing all functions in all system/user modules.-getSymbolTable :: IOish m => GhcModT m [(Symbol,[ModuleString])]-getSymbolTable = do-    ghcModules <- G.packageDbModules True-    moduleInfos <- mapM G.getModuleInfo ghcModules-    let modules = do-         m <- ghcModules-         let moduleName = G.moduleNameString $ G.moduleName m---             modulePkg = G.packageIdString $ G.modulePackageId m-         return moduleName--    return $ collectModules-           $ extractBindings `concatMap` (moduleInfos `zip` modules)--extractBindings :: (Maybe G.ModuleInfo, ModuleString)-                -> [(Symbol, ModuleString)]-extractBindings (Nothing,_)  = []-extractBindings (Just inf,mdlname) =-    map (\name -> (getOccString name, mdlname)) names-  where-    names = G.modInfoExports inf--collectModules :: [(Symbol,ModuleString)]-               -> [(Symbol,[ModuleString])]-collectModules = map tieup . groupBy ((==) `on` fst) . sort-  where-    tieup x = (head (map fst x), map snd x)----- Copied from ghc module `Packages' unfortunately it's not exported :/-resolvePackageDb :: DynFlags -> GhcPkgDb -> IO (Maybe FilePath)-resolvePackageDb df GlobalDb         = return $ Just (systemPackageConfig df)-resolvePackageDb _  (PackageDb name) = return $ Just name-resolvePackageDb _  UserDb           = handleIO (\_ -> return Nothing) $ do-    appdir <- getAppUserDataDirectory "ghc"-    let dir = appdir </> (target_arch ++ '-':target_os ++ '-':cProjectVersion)-        pkgconf = dir </> packageConfDir-    exist <- doesDirectoryExist pkgconf-    return $ if exist then Just pkgconf else Nothing-  where-    [target_arch,_,target_os] = splitOn "-" cTargetPlatformString
− Language/Haskell/GhcMod/Flag.hs 
@@ -1,13 +0,0 @@-module Language.Haskell.GhcMod.Flag where--import qualified Language.Haskell.GhcMod.Gap as Gap-import Language.Haskell.GhcMod.Convert-import Language.Haskell.GhcMod.Monad---- | Listing GHC flags. (e.g -fno-warn-orphans)--flags :: IOish m => GhcModT m String-flags = convert' [ "-f" ++ prefix ++ option-                 | option <- Gap.fOptions-                 , prefix <- ["","no-"]-                 ]
− Language/Haskell/GhcMod/GHCApi.hs 
@@ -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
− Language/Haskell/GhcMod/GHCChoice.hs 
@@ -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
− Language/Haskell/GhcMod/Gap.hs 
@@ -1,475 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP, ScopedTypeVariables, RankNTypes #-}--module Language.Haskell.GhcMod.Gap (-    Language.Haskell.GhcMod.Gap.ClsInst-  , mkTarget-  , withStyle-  , setLogAction-  , getSrcSpan-  , getSrcFile-  , withContext-  , fOptions-  , toStringBuffer-  , showSeverityCaption-  , setCabalPkg-  , setHideAllPackages-  , addPackageFlags-  , setDeferTypeErrors-  , setWarnTypedHoles-  , setDumpSplices-  , isDumpSplices-  , filterOutChildren-  , infoThing-  , pprInfo-  , HasType(..)-  , errorMsgSpan-  , typeForUser-  , nameForUser-  , occNameForUser-  , deSugar-  , showDocWith-  , GapThing(..)-  , fromTyThing-  , fileModSummary-  , WarnFlags-  , emptyWarnFlags-  , benchmarkBuildInfo-  , benchmarkTargets-  , toModuleString-  , GLMatch-  , GLMatchI-  , getClass-  , occName-  , setFlags-  ) where--import Control.Applicative hiding (empty)-import Control.Monad (filterM)-import CoreSyn (CoreExpr)-import Data.List (intersperse)-import Data.Maybe (catMaybes)-import Data.Time.Clock (UTCTime)-import DataCon (dataConRepType)-import Desugar (deSugarExpr)-import DynFlags-import ErrUtils-import FastString-import GhcMonad-import HscTypes-import Language.Haskell.GhcMod.GHCChoice-import Language.Haskell.GhcMod.Types-import NameSet-import OccName-import Outputable-import PprTyThing-import StringBuffer-import TcType-import Var (varType)--import qualified Distribution.PackageDescription as P-import qualified InstEnv-import qualified Pretty-import qualified StringBuffer as SB--#if __GLASGOW_HASKELL__ >= 708-import FamInstEnv-import ConLike (ConLike(..))-import PatSyn (patSynType)-#else-import TcRnTypes-#endif--#if __GLASGOW_HASKELL__ >= 706-import GHC hiding (ClsInst)-#else-import GHC hiding (Instance)-import Control.Arrow hiding ((<+>))-import Data.Convertible-import RdrName (rdrNameOcc)-#endif--#if __GLASGOW_HASKELL__ >= 704-import qualified Data.IntSet as I (IntSet, empty)-import qualified Distribution.ModuleName as M (ModuleName,toFilePath)-#endif---------------------------------------------------------------------------------------------------------------------------------------#if __GLASGOW_HASKELL__ >= 706-type ClsInst = InstEnv.ClsInst-#else-type ClsInst = InstEnv.Instance-#endif--mkTarget :: TargetId -> Bool -> Maybe (SB.StringBuffer, UTCTime) -> Target-#if __GLASGOW_HASKELL__ >= 706-mkTarget = Target-#else-mkTarget tid allowObjCode = Target tid allowObjCode . (fmap . second) convert-#endif-------------------------------------------------------------------------------------------------------------------------------------withStyle :: DynFlags -> PprStyle -> SDoc -> Pretty.Doc-#if __GLASGOW_HASKELL__ >= 706-withStyle = withPprStyleDoc-#else-withStyle _ = withPprStyleDoc-#endif--setLogAction :: DynFlags-             -> (DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ())-             -> DynFlags-setLogAction df f =-#if __GLASGOW_HASKELL__ >= 706-    df { log_action = f }-#else-    df { log_action = f df }-#endif--showDocWith :: DynFlags -> Pretty.Mode -> Pretty.Doc -> String-#if __GLASGOW_HASKELL__ >= 708--- Pretty.showDocWith disappeard.--- https://github.com/ghc/ghc/commit/08a3536e4246e323fbcd8040e0b80001950fe9bc-showDocWith dflags mode = Pretty.showDoc mode (pprCols dflags)-#else-showDocWith _ = Pretty.showDocWith-#endif-------------------------------------------------------------------------------------------------------------------------------------getSrcSpan :: SrcSpan -> Maybe (Int,Int,Int,Int)-#if __GLASGOW_HASKELL__ >= 702-getSrcSpan (RealSrcSpan spn)-#else-getSrcSpan spn | isGoodSrcSpan spn-#endif-             = Just (srcSpanStartLine spn-                   , srcSpanStartCol spn-                   , srcSpanEndLine spn-                   , srcSpanEndCol spn)-getSrcSpan _ = Nothing--getSrcFile :: SrcSpan -> Maybe String-#if __GLASGOW_HASKELL__ >= 702-getSrcFile (RealSrcSpan spn)       = Just . unpackFS . srcSpanFile $ spn-#else-getSrcFile spn | isGoodSrcSpan spn = Just . unpackFS . srcSpanFile $ spn-#endif-getSrcFile _ = Nothing--------------------------------------------------------------------toStringBuffer :: GhcMonad m => [String] -> m StringBuffer-#if __GLASGOW_HASKELL__ >= 702-toStringBuffer = return . stringToStringBuffer . unlines-#else-toStringBuffer = liftIO . stringToStringBuffer . unlines-#endif--------------------------------------------------------------------fOptions :: [String]-#if __GLASGOW_HASKELL__ >= 704-fOptions = [option | (option,_,_) <- fFlags]-        ++ [option | (option,_,_) <- fWarningFlags]-        ++ [option | (option,_,_) <- fLangFlags]-#else-fOptions = [option | (option,_,_,_) <- fFlags]-        ++ [option | (option,_,_,_) <- fWarningFlags]-        ++ [option | (option,_,_,_) <- fLangFlags]-#endif-------------------------------------------------------------------------------------------------------------------------------------fileModSummary :: GhcMonad m => FilePath -> m ModSummary-fileModSummary file = do-    mss <- getModuleGraph-    let [ms] = filter (\m -> ml_hs_file (ms_location m) == Just file) mss-    return ms--withContext :: GhcMonad m => m a -> m a-withContext action = gbracket setup teardown body-  where-    setup = getContext-    teardown = setCtx-    body _ = do-        topImports >>= setCtx-        action-    topImports = do-        mss <- getModuleGraph-        ms <- map modName <$> filterM isTop mss-#if __GLASGOW_HASKELL__ >= 704-        return ms-#else-        return (ms,[])-#endif-    isTop mos = lookupMod mos ||> returnFalse-    lookupMod mos = lookupModule (ms_mod_name mos) Nothing >> return True-    returnFalse = return False-#if __GLASGOW_HASKELL__ >= 706-    modName = IIModule . moduleName . ms_mod-    setCtx = setContext-#elif __GLASGOW_HASKELL__ >= 704-    modName = IIModule . ms_mod-    setCtx = setContext-#else-    modName = ms_mod-    setCtx = uncurry setContext-#endif--showSeverityCaption :: Severity -> String-#if __GLASGOW_HASKELL__ >= 706-showSeverityCaption SevWarning = "Warning: "-showSeverityCaption _          = ""-#else-showSeverityCaption = const ""-#endif-------------------------------------------------------------------------------------------------------------------------------------setCabalPkg :: DynFlags -> DynFlags-#if __GLASGOW_HASKELL__ >= 708-setCabalPkg dflag = gopt_set dflag Opt_BuildingCabalPackage-#else-setCabalPkg dflag = dopt_set dflag Opt_BuildingCabalPackage-#endif--------------------------------------------------------------------setHideAllPackages :: DynFlags -> DynFlags-#if __GLASGOW_HASKELL__ >= 708-setHideAllPackages df = gopt_set df Opt_HideAllPackages-#else-setHideAllPackages df = dopt_set df Opt_HideAllPackages-#endif--addPackageFlags :: [Package] -> DynFlags -> DynFlags-addPackageFlags pkgs df =-    df { packageFlags = packageFlags df ++ expose `map` pkgs }-  where-    expose pkg = ExposePackageId $ showPkgId pkg--------------------------------------------------------------------setDumpSplices :: DynFlags -> DynFlags-setDumpSplices dflag = dopt_set dflag Opt_D_dump_splices--isDumpSplices :: DynFlags -> Bool-isDumpSplices dflag = dopt Opt_D_dump_splices dflag---------------------------------------------------------------------setDeferTypeErrors :: DynFlags -> DynFlags-#if __GLASGOW_HASKELL__ >= 708-setDeferTypeErrors dflag = gopt_set dflag Opt_DeferTypeErrors-#elif __GLASGOW_HASKELL__ >= 706-setDeferTypeErrors dflag = dopt_set dflag Opt_DeferTypeErrors-#else-setDeferTypeErrors = id-#endif--setWarnTypedHoles :: DynFlags -> DynFlags-#if __GLASGOW_HASKELL__ >= 708-setWarnTypedHoles dflag = wopt_set dflag Opt_WarnTypedHoles-#else-setWarnTypedHoles = id-#endif-------------------------------------------------------------------------------------------------------------------------------------class HasType a where-    getType :: GhcMonad m => TypecheckedModule -> a -> m (Maybe (SrcSpan, Type))---instance HasType (LHsBind Id) where-#if __GLASGOW_HASKELL__ >= 708-    getType _ (L spn FunBind{fun_matches = m}) = return $ Just (spn, typ)-      where in_tys = mg_arg_tys m-            out_typ = mg_res_ty m-            typ = mkFunTys in_tys out_typ-#else-    getType _ (L spn FunBind{fun_matches = MatchGroup _ typ}) = return $ Just (spn, typ)-#endif-    getType _ _ = return Nothing-------------------------------------------------------------------------------------------------------------------------------------- from ghc/InteractiveUI.hs--filterOutChildren :: (a -> TyThing) -> [a] -> [a]-filterOutChildren get_thing xs-    = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]-  where-    implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]--infoThing :: GhcMonad m => String -> m SDoc-infoThing str = do-    names <- parseName str-#if __GLASGOW_HASKELL__ >= 708-    mb_stuffs <- mapM (getInfo False) names-    let filtered = filterOutChildren (\(t,_f,_i,_fam) -> t) (catMaybes mb_stuffs)-#else-    mb_stuffs <- mapM getInfo names-    let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)-#endif-    return $ vcat (intersperse (text "") $ map (pprInfo False) filtered)--#if __GLASGOW_HASKELL__ >= 708-pprInfo :: Bool -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc-pprInfo _ (thing, fixity, insts, famInsts)-    = pprTyThingInContextLoc thing-   $$ show_fixity fixity-   $$ InstEnv.pprInstances insts-   $$ pprFamInsts famInsts-  where-    show_fixity fx-      | fx == defaultFixity = Outputable.empty-      | otherwise           = ppr fx <+> ppr (getName thing)-#else-pprInfo :: PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst]) -> SDoc-pprInfo pefas (thing, fixity, insts)-    = pprTyThingInContextLoc pefas thing-   $$ show_fixity fixity-   $$ vcat (map pprInstance insts)-  where-    show_fixity fx-      | fx == defaultFixity = Outputable.empty-      | otherwise           = ppr fx <+> ppr (getName thing)-#endif-------------------------------------------------------------------------------------------------------------------------------------errorMsgSpan :: ErrMsg -> SrcSpan-#if __GLASGOW_HASKELL__ >= 708-errorMsgSpan = errMsgSpan-#else-errorMsgSpan = head . errMsgSpans-#endif--typeForUser :: Type -> SDoc-#if __GLASGOW_HASKELL__ >= 708-typeForUser = pprTypeForUser-#else-typeForUser = pprTypeForUser False-#endif--nameForUser :: Name -> SDoc-nameForUser = pprOccName . getOccName--occNameForUser :: OccName -> SDoc-occNameForUser = pprOccName--deSugar :: TypecheckedModule -> LHsExpr Id -> HscEnv-         -> IO (Maybe CoreExpr)-#if __GLASGOW_HASKELL__ >= 708-deSugar _   e hs_env = snd <$> deSugarExpr hs_env e-#else-deSugar tcm e hs_env = snd <$> deSugarExpr hs_env modu rn_env ty_env e-  where-    modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm-    tcgEnv = fst $ tm_internals_ tcm-    rn_env = tcg_rdr_env tcgEnv-    ty_env = tcg_type_env tcgEnv-#endif-------------------------------------------------------------------------------------------------------------------------------------data GapThing = GtA Type | GtT TyCon | GtN--fromTyThing :: TyThing -> GapThing-fromTyThing (AnId i)                   = GtA $ varType i-#if __GLASGOW_HASKELL__ >= 708-fromTyThing (AConLike (RealDataCon d)) = GtA $ dataConRepType d-fromTyThing (AConLike (PatSynCon p))   = GtA $ patSynType p-#else-fromTyThing (ADataCon d)               = GtA $ dataConRepType d-#endif-fromTyThing (ATyCon t)                 = GtT t-fromTyThing _                          = GtN-------------------------------------------------------------------------------------------------------------------------------------#if __GLASGOW_HASKELL__ >= 704-type WarnFlags = I.IntSet-emptyWarnFlags :: WarnFlags-emptyWarnFlags = I.empty-#else-type WarnFlags = [WarningFlag]-emptyWarnFlags :: WarnFlags-emptyWarnFlags = []-#endif-------------------------------------------------------------------------------------------------------------------------------------benchmarkBuildInfo :: P.PackageDescription -> [P.BuildInfo]-#if __GLASGOW_HASKELL__ >= 704-benchmarkBuildInfo pd = map P.benchmarkBuildInfo $ P.benchmarks pd-#else-benchmarkBuildInfo pd = []-#endif--benchmarkTargets :: P.PackageDescription -> [String]-#if __GLASGOW_HASKELL__ >= 704-benchmarkTargets pd = map toModuleString $ concatMap P.benchmarkModules $ P.benchmarks pd-#else-benchmarkTargets = []-#endif--toModuleString :: M.ModuleName -> String-toModuleString mn = fromFilePath $ M.toFilePath mn-  where-    fromFilePath :: FilePath -> String-    fromFilePath fp = map (\c -> if c=='/' then '.' else c) fp-------------------------------------------------------------------------------------------------------------------------------------#if __GLASGOW_HASKELL__ >= 708-type GLMatch = LMatch RdrName (LHsExpr RdrName)-type GLMatchI = LMatch Id (LHsExpr Id)-#else-type GLMatch = LMatch RdrName-type GLMatchI = LMatch Id-#endif--getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan)-#if __GLASGOW_HASKELL__ >= 708--- Instance declarations of sort 'instance F (G a)'-getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _))))}))] = Just (className, loc)--- Instance declarations of sort 'instance F G' (no variables)-getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsAppTy (L _ (HsTyVar className)) _))}))] = Just (className, loc)-#elif __GLASGOW_HASKELL__ >= 706-getClass [L loc (ClsInstD (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _)))) _ _ _)] = Just (className, loc)-getClass[L loc (ClsInstD (L _ (HsAppTy (L _ (HsTyVar className)) _)) _ _ _)] = Just (className, loc)-#else-getClass [L loc (InstDecl (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _)))) _ _ _)] = Just (className, loc)-getClass [L loc (InstDecl (L _ (HsAppTy (L _ (HsTyVar className)) _)) _ _ _)] = Just (className, loc)-#endif-getClass _ = Nothing--#if __GLASGOW_HASKELL__ < 706-occName :: RdrName -> OccName-occName = rdrNameOcc-#endif-------------------------------------------------------------------------------------------------------------------------------------setFlags :: DynFlags -> DynFlags-#if __GLASGOW_HASKELL__ >= 708-setFlags df = df `gopt_unset` Opt_SpecConstr -- consume memory if -O2-#else-setFlags = id-#endif
− Language/Haskell/GhcMod/GhcPkg.hs 
@@ -1,97 +0,0 @@-{-# LANGUAGE BangPatterns, ScopedTypeVariables, TupleSections #-}-module Language.Haskell.GhcMod.GhcPkg (-    ghcPkgDbOpt-  , ghcPkgDbStackOpts-  , ghcDbStackOpts-  , ghcDbOpt-  , fromInstalledPackageId-  , fromInstalledPackageId'-  , getSandboxDb-  , getPackageDbStack-  ) where--import Config (cProjectVersionInt)-import Control.Applicative ((<$>))-import Control.Exception (SomeException(..))-import qualified Control.Exception as E-import Data.Char (isSpace)-import Data.List (isPrefixOf, intercalate)-import Data.List.Split (splitOn)-import Distribution.Package (InstalledPackageId(..))-import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Utils-import System.FilePath ((</>))--ghcVersion :: Int-ghcVersion = read cProjectVersionInt---- | Get path to sandbox package db-getSandboxDb :: FilePath -- ^ Path to the cabal package root directory-                         -- (containing the @cabal.sandbox.config@ file)-             -> IO FilePath-getSandboxDb cdir = getSandboxDbDir (cdir </> "cabal.sandbox.config")---- | Extract the sandbox package db directory from the cabal.sandbox.config file.---   Exception is thrown if the sandbox config file is broken.-getSandboxDbDir :: FilePath -- ^ Path to the @cabal.sandbox.config@ file-                -> IO FilePath-getSandboxDbDir sconf = do-    -- Be strict to ensure that an error can be caught.-    !path <- extractValue . parse <$> readFile sconf-    return path-  where-    key = "package-db:"-    keyLen = length key--    parse = head . filter (key `isPrefixOf`) . lines-    extractValue = dropWhileEnd isSpace . dropWhile isSpace . drop keyLen--getPackageDbStack :: FilePath -- ^ Project Directory (where the-                                 -- cabal.sandbox.config file would be if it-                                 -- exists)-                  -> IO [GhcPkgDb]-getPackageDbStack cdir =-    (getSandboxDb cdir >>= \db -> return [GlobalDb, PackageDb db])-      `E.catch` \(_ :: SomeException) -> return [GlobalDb, UserDb]--fromInstalledPackageId' :: InstalledPackageId -> Maybe Package-fromInstalledPackageId' pid = let-    InstalledPackageId pkg = pid-    in case reverse $ splitOn "-" pkg of-      i:v:rest -> Just (intercalate "-" (reverse rest), v, i)-      _ -> Nothing--fromInstalledPackageId :: InstalledPackageId -> Package-fromInstalledPackageId pid =-    case fromInstalledPackageId' pid of-      Just p -> p-      Nothing -> error $-        "fromInstalledPackageId: `"++show pid++"' is not a valid package-id"---- | Get options needed to add a list of package dbs to ghc-pkg's db stack-ghcPkgDbStackOpts :: [GhcPkgDb] -- ^ Package db stack-                  -> [String]-ghcPkgDbStackOpts dbs = ghcPkgDbOpt `concatMap` dbs---- | Get options needed to add a list of package dbs to ghc's db stack-ghcDbStackOpts :: [GhcPkgDb] -- ^ Package db stack-               -> [String]-ghcDbStackOpts dbs = ghcDbOpt `concatMap` dbs--ghcPkgDbOpt :: GhcPkgDb -> [String]-ghcPkgDbOpt GlobalDb = ["--global"]-ghcPkgDbOpt UserDb   = ["--user"]-ghcPkgDbOpt (PackageDb pkgDb)-  | ghcVersion < 706 = ["--no-user-package-conf", "--package-conf=" ++ pkgDb]-  | otherwise        = ["--no-user-package-db",   "--package-db="   ++ pkgDb]--ghcDbOpt :: GhcPkgDb -> [String]-ghcDbOpt GlobalDb-  | ghcVersion < 706 = ["-global-package-conf"]-  | otherwise        = ["-global-package-db"]-ghcDbOpt UserDb-  | ghcVersion < 706 = ["-user-package-conf"]-  | otherwise        = ["-user-package-db"]-ghcDbOpt (PackageDb pkgDb)-  | ghcVersion < 706 = ["-no-user-package-conf", "-package-conf", pkgDb]-  | otherwise        = ["-no-user-package-db",   "-package-db",   pkgDb]
− Language/Haskell/GhcMod/Info.hs 
@@ -1,65 +0,0 @@-module Language.Haskell.GhcMod.Info (-    info-  , types-  ) where--import Control.Applicative ((<$>))-import Data.Function (on)-import Data.List (sortBy)-import Data.Maybe (catMaybes)-import Exception (ghandle, SomeException(..))-import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan, Type)-import qualified GHC as G-import Language.Haskell.GhcMod.Doc (showPage)-import Language.Haskell.GhcMod.Gap (HasType(..))-import qualified Language.Haskell.GhcMod.Gap as Gap-import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.SrcUtils-import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Convert---------------------------------------------------------------------- | Obtaining information of a target expression. (GHCi's info:)-info :: IOish m-     => FilePath     -- ^ A target file.-     -> Expression   -- ^ A Haskell expression.-     -> GhcModT m String-info file expr = do-    opt <- options-    convert opt <$> ghandle handler body-  where-    body = inModuleContext file $ \dflag style -> do-        sdoc <- Gap.infoThing expr-        return $ showPage dflag style sdoc-    handler (SomeException _) = return "Cannot show info"---------------------------------------------------------------------- | Obtaining type of a target expression. (GHCi's type:)-types :: IOish m-      => FilePath     -- ^ A target file.-      -> Int          -- ^ Line number.-      -> Int          -- ^ Column number.-      -> GhcModT m String-types file lineNo colNo = do-    opt <- options-    convert opt <$> ghandle handler body-  where-    body = inModuleContext file $ \dflag style -> do-        modSum <- Gap.fileModSummary file-        srcSpanTypes <- getSrcSpanType modSum lineNo colNo-        return $ map (toTup dflag style) $ sortBy (cmp `on` fst) srcSpanTypes-    handler (SomeException _) = return []--getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)]-getSrcSpanType modSum lineNo colNo = do-    p <- G.parseModule modSum-    tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p-    let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id]-        es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id]-        ps = listifySpans tcs (lineNo, colNo) :: [LPat Id]-    bts <- mapM (getType tcm) bs-    ets <- mapM (getType tcm) es-    pts <- mapM (getType tcm) ps-    return $ catMaybes $ concat [ets, bts, pts]
− Language/Haskell/GhcMod/Internal.hs 
@@ -1,63 +0,0 @@--- | Low level access to the ghc-mod library.--module Language.Haskell.GhcMod.Internal (-  -- * Types-    GHCOption-  , Package-  , PackageBaseName-  , PackageVersion-  , PackageId-  , IncludeDir-  , CompilerOptions(..)-  -- * Cabal API-  , parseCabalFile-  , getCompilerOptions-  , cabalAllBuildInfo-  , cabalDependPackages-  , cabalSourceDirs-  , cabalAllTargets-  -- * GHC.Paths-  , ghcLibDir-  -- * IO-  , getDynamicFlags-  -- * Targets-  , setTargetFiles-  -- * Logging-  , withLogger-  , setNoWarningFlags-  , setAllWarningFlags-  -- * Environment, state and logging-  , GhcModEnv(..)-  , newGhcModEnv-  , GhcModState-  , defaultState-  , CompilerMode(..)-  , GhcModLog-  -- * Monad utilities-  , runGhcModT'-  , hoistGhcModT-  -- ** Accessing 'GhcModEnv' and 'GhcModState'-  , options-  , cradle-  , getCompilerMode-  , setCompilerMode-  , withOptions-  -- * 'GhcMonad' Choice-  , (||>)-  , goNext-  , runAnyOne-  ) where--import GHC.Paths (libdir)--import Language.Haskell.GhcMod.CabalApi-import Language.Haskell.GhcMod.DynFlags-import Language.Haskell.GhcMod.GHCChoice-import Language.Haskell.GhcMod.Logger-import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.Target-import Language.Haskell.GhcMod.Types---- | Obtaining the directory for ghc system libraries.-ghcLibDir :: FilePath-ghcLibDir = libdir
− Language/Haskell/GhcMod/Lang.hs 
@@ -1,10 +0,0 @@-module Language.Haskell.GhcMod.Lang where--import DynFlags (supportedLanguagesAndExtensions)-import Language.Haskell.GhcMod.Convert-import Language.Haskell.GhcMod.Monad---- | Listing language extensions.--languages :: IOish m => GhcModT m String-languages = convert' supportedLanguagesAndExtensions
− Language/Haskell/GhcMod/Lint.hs 
@@ -1,21 +0,0 @@-module Language.Haskell.GhcMod.Lint where--import Exception (ghandle)-import Control.Exception (SomeException(..))-import Language.Haskell.GhcMod.Logger (checkErrorPrefix)-import Language.Haskell.GhcMod.Convert-import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.Types-import Language.Haskell.HLint (hlint)---- | Checking syntax of a target file using hlint.---   Warnings and errors are returned.-lint :: IOish m-     => FilePath  -- ^ A target file.-     -> GhcModT m String-lint file = do-  opt <- options-  ghandle handler . pack =<< liftIO (hlint $ file : "--quiet" : hlintOpts opt)- where-    pack = convert' . map (init . show) -- init drops the last \n.-    handler (SomeException e) = return $ checkErrorPrefix ++ show e ++ "\n"
− Language/Haskell/GhcMod/Logger.hs 
@@ -1,232 +0,0 @@-{-# LANGUAGE CPP #-}--module Language.Haskell.GhcMod.Logger (-    withLogger-  , withLoggerTwice-  , checkErrorPrefix-  ) where--import Bag (Bag, bagToList, emptyBag, consBag, filterBag, unionBags)-import Control.Applicative ((<$>))-import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)-import Data.List (isPrefixOf, find, nub, isInfixOf)-import Data.Maybe (fromMaybe, isJust)-import ErrUtils (ErrMsg, WarnMsg, errMsgShortDoc, errMsgExtraInfo, mkWarnMsg)-import Exception (ghandle)-import GHC (DynFlags, SrcSpan, Severity(SevError))-import qualified GHC as G-import HscTypes (SourceError, srcErrorMessages)-import Language.Haskell.GhcMod.Doc (showPage, getStyle)-import Language.Haskell.GhcMod.DynFlags (withDynFlags, withCmdFlags)-import qualified Language.Haskell.GhcMod.Gap as Gap-import Language.Haskell.GhcMod.Convert (convert')-import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.Types-import Outputable (PprStyle, SDoc, qualName, qualModule, mkErrStyle, neverQualify)-import System.FilePath (normalise)--------------------------------------------------------------------type Builder = [String] -> [String]--data Log = Log [String] Builder--newtype LogRef = LogRef (IORef Log)--emptyLog :: Log-emptyLog = Log [] id--newLogRef :: IO LogRef-newLogRef = LogRef <$> newIORef emptyLog--readAndClearLogRef :: IOish m => LogRef -> GhcModT m String-readAndClearLogRef (LogRef ref) = do-    Log _ b <- liftIO $ readIORef ref-    liftIO $ writeIORef ref emptyLog-    convert' (b [])--appendLogRef :: DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()-appendLogRef df (LogRef ref) _ sev src style msg = modifyIORef ref update-  where-    l = ppMsg src sev df style msg-    update lg@(Log ls b)-      | l `elem` ls = lg-      | otherwise   = Log (l:ls) (b . (l:))--------------------------------------------------------------------data LogBag = LogBag (Bag WarnMsg)-newtype LogBagRef = LogBagRef (IORef LogBag)--emptyLogBag :: LogBag-emptyLogBag = LogBag emptyBag--newLogBagRef :: IO LogBagRef-newLogBagRef = LogBagRef <$> newIORef emptyLogBag--readAndClearLogBagRef :: IOish m => LogBagRef -> GhcModT m (Bag WarnMsg)-readAndClearLogBagRef (LogBagRef ref) = do-    LogBag b <- liftIO $ readIORef ref-    liftIO $ writeIORef ref emptyLogBag-    return b--appendLogBagRef :: DynFlags -> LogBagRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()-appendLogBagRef df (LogBagRef ref) _ _ src style msg = modifyIORef ref update-  where-    qstyle = (qualName style, qualModule style)-#if __GLASGOW_HASKELL__ >= 706-    warnMsg = mkWarnMsg df src qstyle msg-#else-    warnMsg = mkWarnMsg src qstyle msg-#endif-    warnBag = consBag warnMsg emptyBag-    update (LogBag b) = let (b1,b2) = mergeErrors df style b warnBag-                         in LogBag $ b1 `unionBags` b2---------------------------------------------------------------------- | Set the session flag (e.g. "-Wall" or "-w:") then---   executes a body. Logged messages are returned as 'String'.---   Right is success and Left is failure.-withLogger :: IOish m-           => (DynFlags -> DynFlags)-           -> GhcModT m ()-           -> GhcModT m (Either String String)-withLogger setDF body = ghandle sourceError $ do-    logref <- liftIO newLogRef-    wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options-    withDynFlags (setLogger logref . setDF) $-        withCmdFlags wflags $ do-            body-            Right <$> readAndClearLogRef logref-  where-    setLogger logref df = Gap.setLogAction df $ appendLogRef df logref--withLoggerTwice :: IOish m-                => (DynFlags -> DynFlags)-                -> GhcModT m ()-                -> (DynFlags -> DynFlags)-                -> GhcModT m ()-                -> GhcModT m (Either String String)-withLoggerTwice setDF1 body1 setDF2 body2 = do-  err1 <- ghandle sourceErrorBag $ do-    logref <- liftIO newLogBagRef-    wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options-    withDynFlags (setLogger logref . setDF1) $-        withCmdFlags wflags $ do-            body1-            Right <$> readAndClearLogBagRef logref-  err2 <- ghandle sourceErrorBag $ do-    logref <- liftIO newLogBagRef-    wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options-    withDynFlags (setLogger logref . setDF2) $-        withCmdFlags wflags $ do-            body2-            Right <$> readAndClearLogBagRef logref-  -- Merge errors and warnings-  dflags <- G.getSessionDynFlags-  style <- getStyle-  case (err1, err2) of-    (Right b1, Right b2) -> do let (warn1,_) = mergeErrors dflags style b1 b2-                               errAndWarnBagToStr Right emptyBag (warn1 `unionBags` b2)-    (Left  b1, Right b2) -> do let (err,warn) = mergeErrors dflags style b1 b2-                               errAndWarnBagToStr Right err warn-    (Right b1, Left  b2) -> do let (err,warn) = mergeErrors dflags style b2 b1-                               errAndWarnBagToStr Right err warn-    (Left  b1, Left  b2) -> do let (err1',err2') = mergeErrors dflags style b1 b2-                               errAndWarnBagToStr Right (err1' `unionBags` err2') emptyBag-  where-    setLogger logref df = Gap.setLogAction df $ appendLogBagRef df logref---------------------------------------------------------------------- | Converting 'SourceError' to 'String'.-sourceError :: IOish m => SourceError -> GhcModT m (Either String String)-sourceError err = errBagToStr (srcErrorMessages err)--errBagToStr :: IOish m => Bag ErrMsg -> GhcModT m (Either String String)-errBagToStr = errBagToStr' Left--errBagToStr' :: IOish m => (String -> a) -> Bag ErrMsg -> GhcModT m a-errBagToStr' f err = do-    dflags <- G.getSessionDynFlags-    style <- getStyle-    ret <- convert' (errBagToStrList dflags style err)-    return $ f ret--errAndWarnBagToStr :: IOish m => (String -> a) -> Bag ErrMsg -> Bag WarnMsg -> GhcModT m a-errAndWarnBagToStr f err warn = do-    dflags <- G.getSessionDynFlags-    -- style <- toGhcModT getStyle-#if __GLASGOW_HASKELL__ >= 706-    let style = mkErrStyle dflags neverQualify-#else-    let style = mkErrStyle neverQualify-#endif-    ret <- convert' $ nub (errBagToStrList dflags style err ++ warnBagToStrList dflags style warn)-    return $ f ret--errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String]-errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList--warnBagToStrList :: DynFlags -> PprStyle -> Bag WarnMsg -> [String]-warnBagToStrList dflag style = map (ppWarnMsg dflag style) . reverse . bagToList--sourceErrorBag :: IOish m => SourceError -> GhcModT m (Either (Bag ErrMsg) (Bag WarnMsg))-sourceErrorBag err = return $ Left (srcErrorMessages err)--mergeErrors :: DynFlags -> PprStyle -> Bag ErrMsg -> Bag ErrMsg -> (Bag ErrMsg, Bag ErrMsg)-mergeErrors dflag style b1 b2 =-  let b1Msgs = map (\err1 -> let m = ppWarnMsg dflag style err1 in (m, head $ lines m))-                   (bagToList b1)-      mustBeB2 = \err2 -> let msg2  = ppWarnMsg dflag style err2-                              line2 = head $ lines msg2-                           in not . isJust $ find (\(msg1, line1) -> msg1 == msg2 || (line1 == line2 && isHoleMsg line1)) b1Msgs-   in (b1, filterBag mustBeB2 b2)--isHoleMsg :: String -> Bool-isHoleMsg = isInfixOf "Found hole"--------------------------------------------------------------------ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String-ppErrMsg dflag style err = ppMsg spn SevError dflag style msg ++ (if null ext then "" else "\n" ++ ext)-   where-     spn = Gap.errorMsgSpan err-     msg = errMsgShortDoc err-     ext = showPage dflag style (errMsgExtraInfo err)--ppWarnMsg :: DynFlags -> PprStyle -> ErrMsg -> String-ppWarnMsg dflag style err = ppMsg spn G.SevWarning dflag style msg ++ (if null ext then "" else "\n" ++ ext)-   where-     spn = Gap.errorMsgSpan err-     msg = errMsgShortDoc err-     ext = showPage dflag style (errMsgExtraInfo err)--ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String-ppMsg spn sev dflag style msg = prefix ++ cts-  where-    cts  = showPage dflag style msg-    prefix = ppMsgPrefix spn sev dflag style cts--ppMsgPrefix :: SrcSpan -> Severity-> DynFlags -> PprStyle -> String -> String-ppMsgPrefix spn sev dflag _style cts =-  let defaultPrefix-        | Gap.isDumpSplices dflag = ""-        | otherwise               = checkErrorPrefix-   in fromMaybe defaultPrefix $ do-        (line,col,_,_) <- Gap.getSrcSpan spn-        file <- normalise <$> Gap.getSrcFile spn-        let severityCaption = Gap.showSeverityCaption sev-            pref0 | or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes)-                              = file ++ ":" ++ show line ++ ":" ++ show col ++ ":"-                  | otherwise = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption-        return pref0--checkErrorPrefix :: String-checkErrorPrefix = "Dummy:0:0:Error:"--warningAsErrorPrefixes :: [String]-warningAsErrorPrefixes = ["Couldn't match expected type"-                         , "Couldn't match type"-                         , "No instance for"]
− Language/Haskell/GhcMod/Modules.hs 
@@ -1,32 +0,0 @@-module Language.Haskell.GhcMod.Modules (modules) where--import Control.Applicative ((<$>))-import Control.Exception (SomeException(..))-import Data.List (nub, sort)-import qualified GHC as G-import Language.Haskell.GhcMod.Convert-import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.Types-import Packages (pkgIdMap, exposedModules, sourcePackageId, display)-import UniqFM (eltsUFM)---------------------------------------------------------------------- | Listing installed modules.-modules :: IOish m => GhcModT m String-modules = do-    opt <- options-    convert opt . arrange opt <$> (getModules `G.gcatch` handler)-  where-    getModules = getExposedModules <$> G.getSessionDynFlags-    getExposedModules = concatMap exposedModules'-                      . eltsUFM . pkgIdMap . G.pkgState-    exposedModules' p =-        map G.moduleNameString (exposedModules p)-    	`zip`-        repeat (display $ sourcePackageId p)-    arrange opt = nub . sort . map (dropPkgs opt)-    dropPkgs opt (name, pkg)-      | detailed opt = name ++ " " ++ pkg-      | otherwise = name-    handler (SomeException _) = return []
− Language/Haskell/GhcMod/Monad.hs 
@@ -1,432 +0,0 @@-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-}-{-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Language.Haskell.GhcMod.Monad (-  -- * Monad Types-    GhcModT-  , IOish-  -- ** Environment, state and logging-  , GhcModEnv(..)-  , newGhcModEnv-  , GhcModState(..)-  , defaultState-  , CompilerMode(..)-  , GhcModLog-  , GhcModError(..)-  -- * Monad utilities-  , runGhcModT-  , runGhcModT'-  , hoistGhcModT-  -- ** Accessing 'GhcModEnv' and 'GhcModState'-  , gmsGet-  , gmsPut-  , options-  , cradle-  , getCompilerMode-  , setCompilerMode-  , withOptions-  , withTempSession-  , overrideGhcUserOptions-  -- ** Re-exporting convenient stuff-  , liftIO-  , module Control.Monad.Reader.Class-  , module Control.Monad.Journal.Class-  ) where--#if __GLASGOW_HASKELL__ < 708--- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different--- classes before ghc 7.8-#define DIFFERENT_MONADIO 1---- RWST doen't have a MonadIO instance before ghc 7.8-#define MONADIO_INSTANCES 1-#endif---import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Error-import Language.Haskell.GhcMod.Cradle-import Language.Haskell.GhcMod.DynFlags-import Language.Haskell.GhcMod.GhcPkg-import Language.Haskell.GhcMod.CabalApi-import qualified Language.Haskell.GhcMod.Gap as Gap--import DynFlags-import GHC-import qualified GHC as G-import GHC.Paths (libdir)-import GhcMonad hiding (withTempSession)-#if __GLASGOW_HASKELL__ <= 702-import HscTypes-#endif---- MonadUtils of GHC 7.6 or earlier defines its own MonadIO.--- RWST does not automatically become an instance of MonadIO.--- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class.--- So, RWST automatically becomes an instance of MonadIO.-import MonadUtils--#if DIFFERENT_MONADIO-import Control.Monad.Trans.Class (lift)-import qualified Control.Monad.IO.Class-import Data.Monoid (Monoid)-#endif--import Control.Applicative (Alternative)-import Control.Arrow (first)-import Control.Monad (MonadPlus, void, liftM)-import Control.Monad.Base (MonadBase, liftBase)---- Monad transformer stuff-import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith,-  control, liftBaseOp, liftBaseOp_)--import Control.Monad.Trans.Class-import Control.Monad.Reader.Class-import Control.Monad.Writer.Class (MonadWriter)-import Control.Monad.State.Class (MonadState(..))--import Control.Monad.Error (ErrorT, runErrorT)-import Control.Monad.Reader (ReaderT, runReaderT)-import Control.Monad.State.Strict (StateT, runStateT)-import Control.Monad.Trans.Journal (JournalT, runJournalT)-#ifdef MONADIO_INSTANCES-import Control.Monad.Trans.Maybe (MaybeT)-import Control.Monad.Error (Error(..))-#endif-import Control.Monad.Journal.Class--import Data.Maybe (fromJust, isJust)-import Data.IORef (IORef, readIORef, writeIORef, newIORef)-import System.Directory (getCurrentDirectory)-import System.IO.Error (tryIOError)--------------------------------------------------------------------data GhcModEnv = GhcModEnv {-      gmGhcSession :: !(IORef HscEnv)-    , gmOptions    :: Options-    , gmCradle     :: Cradle-    }--type GhcModLog = ()--data GhcModState = GhcModState {-      gmCompilerMode :: CompilerMode-    } deriving (Eq,Show,Read)--data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read)--defaultState :: GhcModState-defaultState = GhcModState Simple---------------------------------------------------------------------- | This is basically a newtype wrapper around 'StateT', 'ErrorT', 'JournalT'--- and 'ReaderT' with custom instances for 'GhcMonad' and it's constraints that--- means you can run (almost) all functions from the GHC API on top of 'GhcModT'--- transparently.------ The inner monad @m@ should have instances for 'MonadIO' and--- 'MonadBaseControl' 'IO', in the common case this is simply 'IO'. Most @mtl@--- monads already have 'MonadBaseControl' 'IO' instances, see the--- @monad-control@ package.-newtype GhcModT m a = GhcModT {-      unGhcModT :: StateT GhcModState-                     (ErrorT GhcModError-                       (JournalT GhcModLog-                         (ReaderT GhcModEnv m) ) ) a-    } deriving ( Functor-               , Applicative-               , Alternative-               , Monad-               , MonadPlus-#if DIFFERENT_MONADIO-               , Control.Monad.IO.Class.MonadIO-#endif-               , MonadReader GhcModEnv -- TODO: make MonadReader instance-                                       -- pass-through like MonadState-               , MonadWriter w-               , MonadError GhcModError-               )--instance MonadIO m => MonadIO (GhcModT m) where-    liftIO action = do-      res <- GhcModT . liftIO . liftIO . liftIO . liftIO $ tryIOError action-      case res of-        Right a -> return a-        Left e -> case show e of-          ""  -> throwError $ noMsg-          msg -> throwError $ strMsg msg--instance MonadTrans (GhcModT) where-    lift = GhcModT . lift . lift . lift . lift--instance MonadState s m => MonadState s (GhcModT m) where-    get = GhcModT $ lift $ lift $ lift get-    put = GhcModT . lift . lift . lift . put-    state = GhcModT . lift . lift . lift . state---#if MONADIO_INSTANCES-instance MonadIO m => MonadIO (StateT s m) where-    liftIO = lift . liftIO--instance MonadIO m => MonadIO (ReaderT r m) where-    liftIO = lift . liftIO--instance (Monoid w, MonadIO m) => MonadIO (JournalT w m) where-    liftIO = lift . liftIO--instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where-    liftIO = lift . liftIO--instance MonadIO m => MonadIO (MaybeT m) where-    liftIO = lift . liftIO-#endif---------------------------------------------------------------------- | Initialize the 'DynFlags' relating to the compilation of a single--- file or GHC session according to the 'Cradle' and 'Options'--- provided.-initializeFlagsWithCradle :: (IOish m, GhcMonad m, MonadError GhcModError m)-        => Options-        -> Cradle-        -> m ()-initializeFlagsWithCradle opt c-  | cabal     = withCabal-  | otherwise = withSandbox-  where-    mCradleFile = cradleCabalFile c-    cabal = isJust mCradleFile-    ghcopts = ghcUserOptions opt-    withCabal = do-        pkgDesc <- parseCabalFile c $ fromJust mCradleFile-        compOpts <- getCompilerOptions ghcopts c pkgDesc-        initSession CabalPkg opt compOpts-    withSandbox = initSession SingleFile opt compOpts-      where-        importDirs = [".","..","../..","../../..","../../../..","../../../../.."]-        pkgOpts = ghcDbStackOpts $ cradlePkgDbStack c-        compOpts-          | null pkgOpts = CompilerOptions ghcopts importDirs []-          | otherwise    = CompilerOptions (ghcopts ++ pkgOpts) [wdir,rdir] []-        wdir = cradleCurrentDir c-        rdir = cradleRootDir    c--initSession :: GhcMonad m-            => Build-            -> Options-            -> CompilerOptions-            -> m ()-initSession build Options {..} CompilerOptions {..} = do-    df <- G.getSessionDynFlags-    void $ G.setSessionDynFlags =<< addCmdOpts ghcOptions-      ( setModeSimple-      $ Gap.setFlags-      $ setIncludeDirs includeDirs-      $ setBuildEnv build-      $ setEmptyLogger-      $ Gap.addPackageFlags depPackages df)--------------------------------------------------------------------newGhcModEnv :: Options -> FilePath -> IO GhcModEnv-newGhcModEnv opt dir = do-      session <- newIORef (error "empty session")-      c <- findCradle' dir-      return GhcModEnv {-          gmGhcSession = session-        , gmOptions = opt-        , gmCradle = c-        }---- | Run a @GhcModT m@ computation.-runGhcModT :: IOish m-           => Options-           -> GhcModT m a-           -> m (Either GhcModError a, GhcModLog)-runGhcModT opt action = do-    env <- liftBase $ newGhcModEnv opt =<< getCurrentDirectory-    first (fst <$>) <$> (runGhcModT' env defaultState $ do-        dflags <- getSessionDynFlags-        defaultCleanupHandler dflags $ do-            initializeFlagsWithCradle opt (gmCradle env)-            action)---- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT--- computation. Note that if the computation that returned @result@ modified the--- state part of GhcModT this cannot be restored.-hoistGhcModT :: IOish m-             => (Either GhcModError a, GhcModLog)-             -> GhcModT m a-hoistGhcModT (r,l) = do-  GhcModT (lift $ lift $ journal l) >> case r of-    Left e -> throwError e-    Right a -> return a---- | Run a computation inside @GhcModT@ providing the RWST environment and--- initial state. This is a low level function, use it only if you know what to--- do with 'GhcModEnv' and 'GhcModState'.------ You should probably look at 'runGhcModT' instead.-runGhcModT' :: IOish m-           => GhcModEnv-           -> GhcModState-           -> GhcModT m a-           -> m (Either GhcModError (a, GhcModState), GhcModLog)-runGhcModT' r s a = do-  (res, w') <--      flip runReaderT r $ runJournalT $ runErrorT $-        runStateT (unGhcModT $ initGhcMonad (Just libdir) >> a) s-  return (res, w')-------------------------------------------------------------------- | Make a copy of the 'gmGhcSession' IORef, run the action and restore the--- original 'HscEnv'.-withTempSession :: IOish m => GhcModT m a -> GhcModT m a-withTempSession action = do-  session <- gmGhcSession <$> ask-  savedHscEnv <- liftIO $ readIORef session-  a <- action-  liftIO $ writeIORef session savedHscEnv-  return a---- | This is a very ugly workaround don't use it.-overrideGhcUserOptions :: IOish m => ([GHCOption] -> GhcModT m b) -> GhcModT m b-overrideGhcUserOptions action = withTempSession $ do-  env <- ask-  opt <- options-  let ghcOpts = ghcUserOptions opt-      opt' = opt { ghcUserOptions = [] }--  initializeFlagsWithCradle opt' (gmCradle env)--  action ghcOpts--------------------------------------------------------------------gmeAsk :: IOish m => GhcModT m GhcModEnv-gmeAsk = ask--gmsGet :: IOish m => GhcModT m GhcModState-gmsGet = GhcModT get--gmsPut :: IOish m => GhcModState -> GhcModT m ()-gmsPut = GhcModT . put--options :: IOish m => GhcModT m Options-options = gmOptions <$> gmeAsk--cradle :: IOish m => GhcModT m Cradle-cradle = gmCradle <$> gmeAsk--getCompilerMode :: IOish m => GhcModT m CompilerMode-getCompilerMode = gmCompilerMode <$> gmsGet--setCompilerMode :: IOish m => CompilerMode -> GhcModT m ()-setCompilerMode mode = (\s -> gmsPut s { gmCompilerMode = mode } ) =<< gmsGet--------------------------------------------------------------------withOptions :: IOish m => (Options -> Options) -> GhcModT m a -> GhcModT m a-withOptions changeOpt action = local changeEnv action-  where-    changeEnv e = e { gmOptions = changeOpt opt }-      where-        opt = gmOptions e--------------------------------------------------------------------instance (MonadBaseControl IO m) => MonadBase IO (GhcModT m) where-    liftBase = GhcModT . liftBase--instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where-    newtype StM (GhcModT m) a = StGhcMod {-          unStGhcMod :: StM (StateT GhcModState-                              (ErrorT GhcModError-                                (JournalT GhcModLog-                                  (ReaderT GhcModEnv m) ) ) ) a }-    liftBaseWith f = GhcModT . liftBaseWith $ \runInBase ->-        f $ liftM StGhcMod . runInBase . unGhcModT--    restoreM = GhcModT . restoreM . unStGhcMod-    {-# INLINE liftBaseWith #-}-    {-# INLINE restoreM #-}---- GHC cannot prove the following instances to be decidable automatically using--- the FlexibleContexts extension as they violate the second Paterson Condition,--- namely that: The assertion has fewer constructors and variables (taken--- together and counting repetitions) than the head. Specifically the--- @MonadBaseControl IO m@ constraint is causing this violation.------ Proof of termination:------ Assuming all constraints containing the variable `m' exist and are decidable--- we show termination by manually replacing the current set of constraints with--- their own set of constraints and show that this, after a finite number of--- steps, results in the empty set, i.e. not having to check any more--- constraints.------ We start by setting the constraints to be those immediate constraints of the--- instance declaration which cannot be proven decidable automatically for the--- type under consideration.------ @--- { MonadBaseControl IO m }--- @------ Classes used:------ * @class MonadBase b m => MonadBaseControl b m@------ @--- { MonadBase IO m }--- @------ Classes used:------ * @class (Applicative b, Applicative m, Monad b, Monad m) => MonadBase b m@------ @--- { Applicative IO, Applicative m, Monad IO, Monad m }--- @------ Classes used:------ * @class Monad m@--- * @class Applicative f => Functor f@------ @--- { Functor m }--- @------ Classes used:------ * @class Functor f@------ @--- { }--- @--- ∎--instance (Functor m, MonadIO m, MonadBaseControl IO m)-      => GhcMonad (GhcModT m) where-    getSession = (liftIO . readIORef) . gmGhcSession =<< ask-    setSession a = (liftIO . flip writeIORef a) . gmGhcSession =<< ask--#if __GLASGOW_HASKELL__ >= 706-instance (Functor m, MonadIO m, MonadBaseControl IO m)-      => HasDynFlags (GhcModT m) where-    getDynFlags = getSessionDynFlags-#endif--instance (MonadIO m, MonadBaseControl IO m)-      => ExceptionMonad (GhcModT m) where-    gcatch act handler = control $ \run ->-        run act `gcatch` (run . handler)--    gmask = liftBaseOp gmask . liftRestore-     where liftRestore f r = f $ liftBaseOp_ r
− Language/Haskell/GhcMod/PkgDoc.hs 
@@ -1,26 +0,0 @@-module Language.Haskell.GhcMod.PkgDoc (pkgDoc) where--import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.GhcPkg-import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.Utils--import Control.Applicative ((<$>))---- | Obtaining the package name and the doc path of a module.-pkgDoc :: IOish m => String -> GhcModT m String-pkgDoc mdl = do-    c <- cradle-    pkg <- trim <$> readProcess' "ghc-pkg" (toModuleOpts c)-    if pkg == "" then-        return "\n"-      else do-        htmlpath <- readProcess' "ghc-pkg" (toDocDirOpts pkg c)-        let ret = pkg ++ " " ++ drop 14 htmlpath-        return ret-  where-    toModuleOpts c = ["find-module", mdl, "--simple-output"]-                   ++ ghcPkgDbStackOpts (cradlePkgDbStack c)-    toDocDirOpts pkg c = ["field", pkg, "haddock-html"]-                       ++ ghcPkgDbStackOpts (cradlePkgDbStack c)-    trim = takeWhile (`notElem` " \n")
− Language/Haskell/GhcMod/Read.hs 
@@ -1,106 +0,0 @@-module Language.Haskell.GhcMod.Read where--import Text.Read (readPrec_to_S, readPrec, minPrec)-import qualified Text.ParserCombinators.ReadP as P-import Text.ParserCombinators.ReadPrec (lift)---- This library (libraries/base) is derived from code from several--- sources:----   * Code from the GHC project which is largely (c) The University of---     Glasgow, and distributable under a BSD-style license (see below),----   * Code from the Haskell 98 Report which is (c) Simon Peyton Jones---     and freely redistributable (but see the full license for---     restrictions).----   * Code from the Haskell Foreign Function Interface specification,---     which is (c) Manuel M. T. Chakravarty and freely redistributable---     (but see the full license for restrictions).---- The full text of these licenses is reproduced below.  All of the--- licenses are BSD-style or compatible.---- --------------------------------------------------------------------------------- The Glasgow Haskell Compiler License---- Copyright 2004, The University Court of the University of Glasgow.--- All rights reserved.---- Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are met:---- - Redistributions of source code must retain the above copyright notice,--- this list of conditions and the following disclaimer.---- - Redistributions in binary form must reproduce the above copyright notice,--- this list of conditions and the following disclaimer in the documentation--- and/or other materials provided with the distribution.---- - Neither name of the University nor the names of its contributors may be--- used to endorse or promote products derived from this software without--- specific prior written permission.---- THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF--- GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,--- INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND--- FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE--- UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE--- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR--- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER--- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT--- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY--- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH--- DAMAGE.---- --------------------------------------------------------------------------------- Code derived from the document "Report on the Programming Language--- Haskell 98", is distributed under the following license:----   Copyright (c) 2002 Simon Peyton Jones----   The authors intend this Report to belong to the entire Haskell---   community, and so we grant permission to copy and distribute it for---   any purpose, provided that it is reproduced in its entirety,---   including this Notice.  Modified versions of this Report may also be---   copied and distributed for any purpose, provided that the modified---   version is clearly presented as such, and that it does not claim to---   be a definition of the Haskell 98 Language.---- --------------------------------------------------------------------------------- Code derived from the document "The Haskell 98 Foreign Function--- Interface, An Addendum to the Haskell 98 Report" is distributed under--- the following license:----   Copyright (c) 2002 Manuel M. T. Chakravarty----   The authors intend this Report to belong to the entire Haskell---   community, and so we grant permission to copy and distribute it for---   any purpose, provided that it is reproduced in its entirety,---   including this Notice.  Modified versions of this Report may also be---   copied and distributed for any purpose, provided that the modified---   version is clearly presented as such, and that it does not claim to---   be a definition of the Haskell 98 Foreign Function Interface.---- -------------------------------------------------------------------------------readEither :: Read a => String -> Either String a-readEither s =-  case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of-    [x] -> Right x-    []  -> Left "Prelude.read: no parse"-    _   -> Left "Prelude.read: ambiguous parse"- where-  read' =-    do x <- readPrec-       lift P.skipSpaces-       return x--readMaybe :: Read a => String -> Maybe a-readMaybe s = case readEither s of-                Left _  -> Nothing-                Right a -> Just a
− Language/Haskell/GhcMod/SrcUtils.hs 
@@ -1,106 +0,0 @@-{-# LANGUAGE TupleSections, FlexibleInstances, Rank2Types #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Language.Haskell.GhcMod.SrcUtils where--import Control.Applicative ((<$>))-import CoreUtils (exprType)-import Data.Generics-import Data.Maybe (fromMaybe)-import Data.Ord as O-import GHC (LHsExpr, LPat, Id, DynFlags, SrcSpan, Type, Located, ParsedSource, RenamedSource, TypecheckedSource, GenLocated(L))-import qualified GHC as G-import GHC.SYB.Utils (Stage(..), everythingStaged)-import GhcMonad-import qualified Language.Haskell.Exts.Annotated as HE-import Language.Haskell.GhcMod.Doc (showOneLine, getStyle)-import Language.Haskell.GhcMod.DynFlags-import Language.Haskell.GhcMod.Gap (HasType(..), setWarnTypedHoles, setDeferTypeErrors)-import qualified Language.Haskell.GhcMod.Gap as Gap-import Language.Haskell.GhcMod.Monad (IOish, GhcModT)-import Language.Haskell.GhcMod.Target (setTargetFiles)-import OccName (OccName)-import Outputable (PprStyle)-import TcHsSyn (hsPatType)--------------------------------------------------------------------instance HasType (LHsExpr Id) where-    getType tcm e = do-        hs_env <- G.getSession-        mbe <- liftIO $ Gap.deSugar tcm e hs_env-        return $ (G.getLoc e, ) <$> CoreUtils.exprType <$> mbe--instance HasType (LPat Id) where-    getType _ (G.L spn pat) = return $ Just (spn, hsPatType pat)--------------------------------------------------------------------listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a]-listifySpans tcs lc = listifyStaged TypeChecker p tcs-  where-    p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc--listifyParsedSpans :: Typeable a => ParsedSource -> (Int, Int) -> [Located a]-listifyParsedSpans pcs lc = listifyStaged Parser p pcs-  where-    p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc--listifyRenamedSpans :: Typeable a => RenamedSource -> (Int, Int) -> [Located a]-listifyRenamedSpans pcs lc = listifyStaged Renamer p pcs-  where-    p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc--listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r]-listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x]))--cmp :: SrcSpan -> SrcSpan -> Ordering-cmp a b-  | a `G.isSubspanOf` b = O.LT-  | b `G.isSubspanOf` a = O.GT-  | otherwise           = O.EQ--toTup :: DynFlags -> PprStyle -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String)-toTup dflag style (spn, typ) = (fourInts spn, pretty dflag style typ)--fourInts :: SrcSpan -> (Int,Int,Int,Int)-fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan--fourIntsHE :: HE.SrcSpan -> (Int,Int,Int,Int)-fourIntsHE loc = ( HE.srcSpanStartLine loc, HE.srcSpanStartColumn loc-                 , HE.srcSpanEndLine loc, HE.srcSpanEndColumn loc)---- Check whether (line,col) is inside a given SrcSpanInfo-typeSigInRangeHE :: Int -> Int -> HE.Decl HE.SrcSpanInfo -> Bool-typeSigInRangeHE lineNo colNo (HE.TypeSig (HE.SrcSpanInfo s _) _ _) =-  HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo)-typeSigInRangeHE lineNo colNo (HE.TypeFamDecl (HE.SrcSpanInfo s _) _ _) =-  HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo)-typeSigInRangeHE lineNo colNo (HE.DataFamDecl (HE.SrcSpanInfo s _) _ _ _) =-  HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo)-typeSigInRangeHE _  _ _= False--pretty :: DynFlags -> PprStyle -> Type -> String-pretty dflag style = showOneLine dflag style . Gap.typeForUser--------------------------------------------------------------------inModuleContext :: IOish m-                => FilePath-                -> (DynFlags -> PprStyle -> GhcModT m a)-                -> GhcModT m a-inModuleContext file action =-    withDynFlags (setWarnTypedHoles . setDeferTypeErrors . setNoWarningFlags) $ do-    setTargetFiles [file]-    Gap.withContext $ do-        dflag <- G.getSessionDynFlags-        style <- getStyle-        action dflag style--------------------------------------------------------------------showName :: DynFlags -> PprStyle -> G.Name -> String-showName dflag style name = showOneLine dflag style $ Gap.nameForUser name--showOccName :: DynFlags -> PprStyle -> OccName -> String-showOccName dflag style name = showOneLine dflag style $ Gap.occNameForUser name
− Language/Haskell/GhcMod/Target.hs 
@@ -1,60 +0,0 @@-{-# LANGUAGE CPP #-}-module Language.Haskell.GhcMod.Target (-    setTargetFiles-  ) where--import Control.Applicative ((<$>))-import Control.Monad (forM, void, (>=>))-import DynFlags (ExtensionFlag(..), xopt)-import GHC (LoadHowMuch(..))-import qualified GHC as G-import Language.Haskell.GhcMod.DynFlags-import Language.Haskell.GhcMod.Monad---- | Set the files as targets and load them.-setTargetFiles :: IOish m => [FilePath] -> GhcModT m ()-setTargetFiles files = do-    targets <- forM files $ \file -> G.guessTarget file Nothing-    G.setTargets targets-    mode <- getCompilerMode-    if mode == Intelligent then-        loadTargets Intelligent-      else do-        mdls <- G.depanal [] False-        let fallback = needsFallback mdls-        if fallback then do-            resetTargets targets-            setIntelligent-            loadTargets Intelligent-          else-            loadTargets Simple-  where-    loadTargets Simple = do-        -- Reporting error A and error B-        void $ G.load LoadAllTargets-        mss <- filter (\x -> G.ms_hspp_file x `elem` files) <$> G.getModuleGraph-        -- Reporting error B and error C-        mapM_ (G.parseModule >=> G.typecheckModule >=> G.desugarModule) mss-        -- Error B duplicates. But we cannot ignore both error reportings,-        -- sigh. So, the logger makes log messages unique by itself.-    loadTargets Intelligent = do-        df <- G.getSessionDynFlags-        void $ G.setSessionDynFlags (setModeIntelligent df)-        void $ G.load LoadAllTargets-    resetTargets targets = do-        G.setTargets []-        void $ G.load LoadAllTargets-        G.setTargets targets-    setIntelligent = do-        newdf <- setModeIntelligent <$> G.getSessionDynFlags-        void $ G.setSessionDynFlags newdf-        setCompilerMode Intelligent--needsFallback :: G.ModuleGraph -> Bool-needsFallback = any $ \ms ->-                let df = G.ms_hspp_opts ms in-                   Opt_TemplateHaskell `xopt` df-                || Opt_QuasiQuotes     `xopt` df-#if __GLASGOW_HASKELL__ >= 708-                || (Opt_PatternSynonyms `xopt` df)-#endif
− Language/Haskell/GhcMod/Types.hs 
@@ -1,122 +0,0 @@-module Language.Haskell.GhcMod.Types where--import Control.Monad.Trans.Control (MonadBaseControl)-import Data.List (intercalate)-import qualified Data.Map as M-import Exception (ExceptionMonad)-import MonadUtils (MonadIO)--import PackageConfig (PackageConfig)---- | A constraint alias (-XConstraintKinds) to make functions dealing with--- 'GhcModT' somewhat cleaner.------ Basicially an @IOish m => m@ is a 'Monad' supporting arbitrary 'IO' and--- exception handling. Usually this will simply be 'IO' but we parametrise it in--- the exported API so users have the option to use a custom inner monad.-type IOish m = (Functor m, MonadIO m, MonadBaseControl IO m, ExceptionMonad m)---- | Output style.-data OutputStyle = LispStyle  -- ^ S expression style.-                 | PlainStyle -- ^ Plain textstyle.---- | The type for line separator. Historically, a Null string is used.-newtype LineSeparator = LineSeparator String--data Options = Options {-    outputStyle   :: OutputStyle-  , hlintOpts     :: [String]-    -- | GHC command line options set on the @ghc-mod@ command line-  , ghcUserOptions:: [GHCOption]-  -- | If 'True', 'browse' also returns operators.-  , operators     :: Bool-  -- | If 'True', 'browse' also returns types.-  , detailed      :: Bool-  -- | If 'True', 'browse' will return fully qualified name-  , qualified     :: Bool-  -- | Line separator string.-  , lineSeparator :: LineSeparator-  }---- | A default 'Options'.-defaultOptions :: Options-defaultOptions = Options {-    outputStyle   = PlainStyle-  , hlintOpts     = []-  , ghcUserOptions= []-  , operators     = False-  , detailed      = False-  , qualified     = False-  , lineSeparator = LineSeparator "\0"-  }---------------------------------------------------------------------- | The environment where this library is used.-data Cradle = Cradle {-  -- | The directory where this library is executed.-    cradleCurrentDir :: FilePath-  -- | The project root directory.-  , cradleRootDir    :: FilePath-  -- | The file name of the found cabal file.-  , cradleCabalFile  :: Maybe FilePath-  -- | Package database stack-  , cradlePkgDbStack  :: [GhcPkgDb]-  } deriving (Eq, Show)---------------------------------------------------------------------- | GHC package database flags.-data GhcPkgDb = GlobalDb | UserDb | PackageDb String deriving (Eq, Show)---- | A single GHC command line option.-type GHCOption  = String---- | An include directory for modules.-type IncludeDir = FilePath---- | A package name.-type PackageBaseName = String---- | A package version.-type PackageVersion  = String---- | A package id.-type PackageId  = String---- | A package's name, verson and id.-type Package    = (PackageBaseName, PackageVersion, PackageId)--pkgName :: Package -> PackageBaseName-pkgName (n,_,_) = n--pkgVer :: Package -> PackageVersion-pkgVer (_,v,_) = v--pkgId :: Package -> PackageId-pkgId (_,_,i) = i--showPkg :: Package -> String-showPkg (n,v,_) = intercalate "-" [n,v]--showPkgId :: Package -> String-showPkgId (n,v,i) = intercalate "-" [n,v,i]---- | Collection of packages-type PkgDb = (M.Map Package PackageConfig)---- | Haskell expression.-type Expression = String---- | Module name.-type ModuleString = String---- | A Module-type Module = [String]---- | Option information for GHC-data CompilerOptions = CompilerOptions {-    ghcOptions  :: [GHCOption]  -- ^ Command line options-  , includeDirs :: [IncludeDir] -- ^ Include directories for modules-  , depPackages :: [Package]    -- ^ Dependent package names-  } deriving (Eq, Show)
− Language/Haskell/GhcMod/Utils.hs 
@@ -1,44 +0,0 @@-module Language.Haskell.GhcMod.Utils where---import Language.Haskell.GhcMod.Error-import MonadUtils (MonadIO, liftIO)-import System.Directory (getCurrentDirectory, setCurrentDirectory)-import System.Exit (ExitCode(..))-import System.Process (readProcessWithExitCode)---- dropWhileEnd is not provided prior to base 4.5.0.0.-dropWhileEnd :: (a -> Bool) -> [a] -> [a]-dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) []--extractParens :: String -> String-extractParens str = extractParens' str 0- where-   extractParens' :: String -> Int -> String-   extractParens' [] _ = []-   extractParens' (s:ss) level-       | s `elem` "([{" = s : extractParens' ss (level+1)-       | level == 0 = extractParens' ss 0-       | s `elem` "}])" && level == 1 = [s]-       | s `elem` "}])" = s : extractParens' ss (level-1)-       | otherwise = s : extractParens' ss level--readProcess' :: (MonadIO m, MonadError GhcModError m)-             => String-             -> [String]-             -> m String-readProcess' cmd opts = do-  (rv,output,err) <- liftIO (readProcessWithExitCode cmd opts "")-      `modifyError'` GMEProcess ([cmd] ++ opts)-  case rv of-    ExitFailure val -> do-        throwError $ GMEProcess ([cmd] ++ opts) $ strMsg $-          cmd ++ " " ++ unwords opts ++ " (exit " ++ show val ++ ")"-              ++ "\n" ++ err-    ExitSuccess ->-        return output--withDirectory_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a-withDirectory_ dir action =-    gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory)-                (\_ -> liftIO (setCurrentDirectory dir) >> action)
+ README.md view
@@ -0,0 +1,99 @@+# ghc-mod: Happy Haskell Hacking+[![build status](https://gitlab.com/dxld/ghc-mod/badges/master/build.svg)](https://gitlab.com/dxld/ghc-mod/commits/master)++ghc-mod provides editors/IDEs with support for Haskell compiler features, it+supports both Cabal and Stack based projects and integrations exist for Emacs,+Vim, Atom, IntelliJ and VSCode.++- for [all Haskell developers (Using ghc-mod in your development environment)](#using-ghc-mod-in-your-development-environment)+- for [people developing Haskell IDEs (Using ghc-mod as an IDE backend program)](#using-ghc-mod-as-an-ide-backend-program)+- for [developing Haskell tooling (Using ghc-mod as a library)](#using-ghc-mod-as-a-library)++## Overview++### Using ghc-mod in your Development Environment++To use `ghc-mod` in your development environment of choice you need two things:++  - The `ghc-mod` program included in the package of the same name, see [Installing](https://github.com/DanielG/ghc-mod/wiki/Installing)+  - A ghc-mod frontend to integrate it into your development environment, see [Frontend](https://github.com/DanielG/ghc-mod/wiki/Frontend)++### Using ghc-mod as an IDE Backend Program++We provide two modes of operation for frontends: interactive and single shot+mode. The former is accessed by calling `$ ghc-mod legacy-interactive` this will+sit and wait for you to type a command and exit when an empty line is+entered. Interactive mode is pretty much always faster than single shot mode+since it gives ghc-mod the ability to cache the compiler session between+commands on the other hand it needs more memory because it keeps these things+cached. ++Single shot mode is pretty much only there for (backwards) compatibility with+Vim since it only recently got the ability to talk to background processes+without installing some external plugin. You can use single-shot mode by simply+calling the sub-comamnds of the `ghc-mod` program. Since re-compiling large+projects can be really, really slow you really shouldn't use this and use+interactive mode instead.++As a rule of thumb all commands available in single shot mode are available in+interactive mode, a list of the former can be obtained by running +`$ ghc-mod --help`.++If you're developing a new ghc-mod fronted we'd love to hear from you! Please+open an issue or e-mail the maintainer. Also we invite you to add installation+and configuration instructions to+[Frontend](https://github.com/DanielG/ghc-mod/wiki/Frontend).++### Using ghc-mod as a Library++Internally ghc-mod uses the Glasgow Haskell Compilers's API to implement most of+it's functionality.++In order to provide a hassle free experience to users ghc-mod tries hard to+automatically, and correctly, detect and if needed tweak the environment GHC+needs. It also handles some of the more cumbersome parts of getting a working+compiler session up and running.++This functionality can be very useful to all kinds of Haskell development tools+therefore want to expose all the useful abstractions ghc-mod provides.++Right now the ghc-mod API is pretty messy; a result of major internal rewrites+and reorganization coupled with too little time for cleanups over the course of+almost 100 releases! We would like to make a cut during v6.0 or so and+completely re-do the API but we need more input from downstream tool writers to+do that properly, see [Library API Redesign](Library-API-Redesign.md).++For example [The Haskell Refactorer (HaRe)](https://github.com/alanz/HaRe) uses+the build environment abstraction ghc-mod provides so it can concentrate on it's+core functionality instead of worrying about build environments and compiler+session setup.++Recently the+[`haskell-ide-engine`](https://github.com/haskell/haskell-ide-engine) project+has sprung up and if you're planning to write any kind of tool that needs editor+integration eventually you should definetly look into that. `haskell-ide-engine`+uses `ghc-mod` at it's core so you'll want to be familliar with it either way.++API "documentation" is here:+[Hackage docs](https://hackage.haskell.org/package/ghc-mod#modules).++## Reporting Bugs++Please report bugs on the GitHub issue tracker for ghc-mod:+https://github.com/DanielG/ghc-mod/issues++Including general environment information like the operating system+(distribution, version) you're using and the output of `$ ghc-mod debug` run in+your project directory is probably a good idea.++## IRC++If you have any problems, suggestions, comments swing by+[\#ghc-mod (web client)](https://kiwiirc.com/client/irc.freenode.org/ghc-mod) on+Freenode. If you're reporting a bug please also create an issue+[here (GitHub issue tracker)](https://github.com/DanielG/ghc-mod/issues) so we+have a way to contact you if you don't have time to stay.++Do hang around for a while if no one answers and repeat your question if you+still haven't gotten any answer after a day or so (the maintainer was probably+asleep). You're most likely to get an answer during the day in GMT+1.
Setup.hs view
@@ -1,2 +1,107 @@+#!/usr/bin/env runhaskell+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} import Distribution.Simple-main = defaultMain+import Distribution.Simple.Utils+import Distribution.Simple.Setup+import Distribution.Simple.Install+import Distribution.Simple.Program+import Distribution.Simple.Register+import Distribution.Simple.BuildPaths+import qualified Distribution.Simple.InstallDirs as ID+import Distribution.Simple.LocalBuildInfo+import Distribution.PackageDescription++import qualified Data.Map as M+import Data.Map (Map)++import Control.Arrow+import Control.Applicative+import Control.Monad+import Data.List+import Data.Maybe+import Data.Version+import Data.Monoid+import System.Process+import System.Exit+import System.FilePath+import System.Directory (renameFile)++main :: IO ()+main = defaultMainWithHooks $ simpleUserHooks {+   instHook = inst,+   copyHook = copy,+   buildHook = \pd lbi hooks flags -> (buildHook simpleUserHooks) pd (patchLibexecdir lbi) hooks flags,+   hookedPrograms = [ simpleProgram "shelltest" ]+ }++patchLibexecdir :: LocalBuildInfo -> LocalBuildInfo+patchLibexecdir lbi = let+    idirtpl     = installDirTemplates lbi+    libexecdir' = toPathTemplate $ fromPathTemplate (libexecdir idirtpl) </> "$abi/$pkgid"+    lbi' = lbi { installDirTemplates = idirtpl { libexecdir = libexecdir' } }+  in+    lbi'++-- mostly copypasta from 'defaultInstallHook'+inst ::+    PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO ()+inst pd lbi _uf ifl = do+  let copyFlags = defaultCopyFlags {+                      copyDistPref   = installDistPref ifl,+                      copyDest       = toFlag NoCopyDest,+                      copyVerbosity  = installVerbosity ifl+                  }+  xInstallTarget pd lbi copyFlags (\pd' lbi' -> install pd' lbi' copyFlags)+  let registerFlags = defaultRegisterFlags {+                          regDistPref  = installDistPref ifl,+                          regInPlace   = installInPlace ifl,+                          regPackageDB = installPackageDB ifl,+                          regVerbosity = installVerbosity ifl+                      }+  when (hasLibs pd) $ register pd lbi registerFlags++copy :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO ()+copy pd lbi _uh cf =+    xInstallTarget pd lbi cf (\pd' lbi' -> install pd' lbi' cf)++xInstallTarget :: PackageDescription+               -> LocalBuildInfo+               -> CopyFlags+               -> (PackageDescription -> LocalBuildInfo -> IO ())+               -> IO ()+xInstallTarget pd lbi cf fn = do+  let (extended, regular) = partition isInternal (executables pd)++  let pd_regular = pd { executables = regular }++  _ <- flip mapM extended $ \exe -> do+    let pd_extended = onlyExePackageDesc [exe] pd+    fn pd_extended lbi++    let lbi' = patchLibexecdir lbi+        copydest  = fromFlag (copyDest cf)+        verbosity = fromFlag (copyVerbosity cf)+        InstallDirs { bindir, libexecdir } = absoluteInstallDirs pd lbi' copydest+        progprefix = substPathTemplate (packageId pd) lbi (progPrefix lbi)+        progsuffix = substPathTemplate (packageId pd) lbi (progSuffix lbi)+        fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix++        fixedExeFileName = bindir </> fixedExeBaseName <.> exeExtension+        newExeFileName   = libexecdir </> fixedExeBaseName <.> exeExtension++    when (exeName exe == "ghc-mod-real") $ do+        createDirectoryIfMissingVerbose verbosity True libexecdir+        renameFile fixedExeFileName newExeFileName++  fn pd_regular lbi++ where+   isInternal :: Executable -> Bool+   isInternal exe =+    fromMaybe False $ (=="True") <$> lookup "x-internal" (customFieldsBI $ buildInfo exe)++onlyExePackageDesc :: [Executable] -> PackageDescription -> PackageDescription+onlyExePackageDesc exes pd = emptyPackageDescription {+                     package = package pd+                   , executables = exes+                   }
+ bench/Bench.hs view
@@ -0,0 +1,30 @@+import Criterion.Main+import GhcMod.Target+import GhcMod.Monad+import GhcMod.Types+import Dir+import System.IO.Temp+import System.Process hiding (env)+import Control.Monad++main = defaultMain [+    env setup $ \dir -> bgroup "simple-cabal" [+        bench "nop" $ whnfIO (simpleCabalNop dir 1)+      , bench "nop10" $ whnfIO (simpleCabalNop dir 10)+      ]+  ]++setup = do+  tdir <- createTempDirectory "/tmp" "ghc-mod-bench"+  system $ "cp -rv \"bench/data/simple-cabal/\" \""++ tdir ++"\""++  simpleCabalNop tdir 1 -- warmup dist/++  return tdir++simpleCabalNop :: FilePath -> Int -> IO ()+simpleCabalNop dir n = withDirectory_ (dir </> "simple-cabal") $ do+  _ <- runGhcModT defaultOptions $+       forM_ [1..n] $ \_ -> do+           runGmlT [Left "Main.hs"] (return ())+  return ()
+ bench/data/simple-cabal/Main.hs view
@@ -0,0 +1,4 @@+module Main where++main :: IO ()+main = putStrLn "Hello, Haskell!"
+ bench/data/simple-cabal/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/data/simple-cabal/simple-cabal.cabal view
@@ -0,0 +1,13 @@+name:                simple-cabal+version:             0.1.0.0+license:             BSD3+license-file:        LICENSE+author:              Daniel Gröber+maintainer:          dxld@darkboxed.org+build-type:          Simple+cabal-version:       >=1.10++executable simple-cabal+  main-is:             Main.hs+  build-depends:       base+  default-language:    Haskell2010
+ core/Data/Binary/Generic.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, KindSignatures,+    ScopedTypeVariables, TypeOperators, TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-----------------------------------------------------------------------------+-- |+-- Module      : Data.Binary.Generic+-- Copyright   : Bryan O'Sullivan+-- License     : BSD3-style (see LICENSE)+--+-- Maintainer  : Bryan O'Sullivan <bos@serpentine.com>+-- Stability   : unstable+-- Portability : Only works with GHC 7.2 and newer+--+-- Instances for supporting GHC generics.+--+-----------------------------------------------------------------------------+module Data.Binary.Generic where++import Control.Applicative+import Data.Binary+import Data.Bits+import GHC.Generics+import Prelude++class GGBinary f where+    ggput :: f t -> Put+    ggget :: Get (f t)++-- Type without constructors+instance GGBinary V1 where+    ggput _ = return ()+    ggget   = return undefined++-- Constructor without arguments+instance GGBinary U1 where+    ggput U1 = return ()+    ggget    = return U1++-- Product: constructor with parameters+instance (GGBinary a, GGBinary b) => GGBinary (a :*: b) where+    ggput (x :*: y) = ggput x >> ggput y+    ggget = (:*:) <$> ggget <*> ggget++-- Metadata (constructor name, etc)+instance GGBinary a => GGBinary (M1 i c a) where+    ggput = ggput . unM1+    ggget = M1 <$> ggget++-- Constants, additional parameters, and rank-1 recursion+instance Binary a => GGBinary (K1 i a) where+    ggput = put . unK1+    ggget = K1 <$> get++-- Borrowed from the cereal package.++-- The following GGBinary instance for sums has support for serializing+-- types with up to 2^64-1 constructors. It will use the minimal+-- number of bytes needed to encode the constructor. For example when+-- a type has 2^8 constructors or less it will use a single byte to+-- encode the constructor. If it has 2^16 constructors or less it will+-- use two bytes, and so on till 2^64-1.++#define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD)+#define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size)+#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size)++instance ( GSum     a, GSum     b+         , SumSize    a, SumSize    b) => GGBinary (a :+: b) where+    ggput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64)+         | otherwise = sizeError "encode" size+      where+        size = unTagged (sumSize :: Tagged (a :+: b) Word64)+    {-# INLINE ggput #-}++    ggget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) | GETSUM(Word64)+         | otherwise = sizeError "decode" size+      where+        size = unTagged (sumSize :: Tagged (a :+: b) Word64)+    {-# INLINE ggget #-}++sizeError :: Show size => String -> size -> error+sizeError s size =+    error $ "Can't " ++ s ++ " a type with " ++ show size ++ " constructors"++------------------------------------------------------------------------++checkGetSum :: (Ord word, Num word, Bits word, GSum f)+            => word -> word -> Get (f a)+checkGetSum size code | code < size = getSum code size+                      | otherwise   = fail "Unknown encoding for constructor"+{-# INLINE checkGetSum #-}++class GSum f where+    getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a)+    putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put++instance (GSum a, GSum b) => GSum (a :+: b) where+    getSum !code !size | code < sizeL = L1 <$> getSum code           sizeL+                       | otherwise    = R1 <$> getSum (code - sizeL) sizeR+        where+          sizeL = size `shiftR` 1+          sizeR = size - sizeL+    {-# INLINE getSum #-}++    putSum !code !size s = case s of+                             L1 x -> putSum code           sizeL x+                             R1 x -> putSum (code + sizeL) sizeR x+        where+          sizeL = size `shiftR` 1+          sizeR = size - sizeL+    {-# INLINE putSum #-}++instance GGBinary a => GSum (C1 c a) where+    getSum _ _ = ggget+    {-# INLINE getSum #-}++    putSum !code _ x = put code *> ggput x+    {-# INLINE putSum #-}++------------------------------------------------------------------------++class SumSize f where+    sumSize :: Tagged f Word64++newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b}++instance (SumSize a, SumSize b) => SumSize (a :+: b) where+    sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) ++                       unTagged (sumSize :: Tagged b Word64)++instance SumSize (C1 c a) where+    sumSize = Tagged 1
+ core/GhcMod/CabalHelper.hs view
@@ -0,0 +1,309 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP #-}+module GhcMod.CabalHelper+  ( getComponents+  , getGhcMergedPkgOptions+  , getCabalPackageDbStack+  , prepareCabalHelper+  , withAutogen+  , withCabal+  ) where++import Control.Applicative+import Control.Monad+import Control.Category ((.))+import Data.Maybe+import Data.Monoid+import Data.Version+import Data.Binary (Binary)+import Data.Traversable+import Distribution.Helper hiding (Programs(..))+import qualified Distribution.Helper as CH+import qualified GhcMod.Types as T+import GhcMod.Types+import GhcMod.Monad.Types+import GhcMod.Utils+import GhcMod.PathsAndFiles+import GhcMod.Logging+import GhcMod.Output+import GhcMod.CustomPackageDb+import GhcMod.Stack+import System.FilePath+import System.Process+import System.Exit+import Prelude hiding ((.))++import Paths_ghc_mod as GhcMod++-- | Only package related GHC options, sufficient for things that don't need to+-- access home modules+getGhcMergedPkgOptions :: (Applicative m, IOish m, Gm m)+  => m [GHCOption]+getGhcMergedPkgOptions = chCached $ \distdir -> Cached {+  cacheLens = Just (lGmcMergedPkgOptions . lGmCaches),+  cacheFile = mergedPkgOptsCacheFile distdir,+  cachedAction = \_tcf (_progs, _projdir, _ver) _ma -> do+    opts <- runCHQuery ghcMergedPkgOptions+    return ([setupConfigPath distdir], opts)+ }++getCabalPackageDbStack :: (IOish m, Gm m) => m [GhcPkgDb]+getCabalPackageDbStack = chCached $ \distdir -> Cached {+  cacheLens = Just (lGmcPackageDbStack . lGmCaches),+  cacheFile = pkgDbStackCacheFile distdir,+  cachedAction = \_tcf (_progs, _projdir, _ver) _ma -> do+    crdl <- cradle+    dbs <- map chPkgToGhcPkg <$>+             runCHQuery packageDbStack+    return ([setupConfigFile crdl, sandboxConfigFile crdl], dbs)+ }++chPkgToGhcPkg :: ChPkgDb -> GhcPkgDb+chPkgToGhcPkg ChPkgGlobal = GlobalDb+chPkgToGhcPkg ChPkgUser = UserDb+chPkgToGhcPkg (ChPkgSpecific f) = PackageDb f++-- | Primary interface to cabal-helper and intended single entrypoint to+-- constructing 'GmComponent's+--+-- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by+-- 'resolveGmComponents'.+getComponents :: (Applicative m, IOish m, Gm m)+              => m [GmComponent 'GMCRaw ChEntrypoint]+getComponents = chCached $ \distdir -> Cached {+    cacheLens = Just (lGmcComponents . lGmCaches),+    cacheFile = cabalHelperCacheFile distdir,+    cachedAction = \ _tcf (_progs, _projdir, _ver) _ma -> do+      runCHQuery $ do+        q <- join7+               <$> ghcOptions+               <*> ghcPkgOptions+               <*> ghcSrcOptions+               <*> ghcLangOptions+               <*> entrypoints+               <*> entrypoints+               <*> sourceDirs+        let cs = flip map q $ curry8 (GmComponent mempty)+        return ([setupConfigPath distdir], cs)+  }+ where+   curry8 fn (a, (b, (c, (d, (e, (f, (g, h))))))) = fn a b c d e f g h++   join7 a b c d e f = join' a . join' b . join' c . join' d . join' e . join' f+   join' :: Eq a => [(a,b)] -> [(a,c)] -> [(a,(b,c))]+   join' lb lc = [ (a, (b, c))+                 | (a, b)  <- lb+                 , (a', c) <- lc+                 , a == a'+                 ]++getQueryEnv :: (IOish m, GmOut m, GmEnv m) => m QueryEnv+getQueryEnv = do+  crdl <- cradle+  progs <- patchStackPrograms crdl =<< (optPrograms <$> options)+  readProc <- gmReadProcess+  let projdir = cradleRootDir crdl+      distdir = projdir </> cradleDistDir crdl+  return (defaultQueryEnv projdir distdir) {+                  qeReadProcess = readProc+                , qePrograms = helperProgs progs+                }++runCHQuery :: (IOish m, GmOut m, GmEnv m) => Query m b -> m b+runCHQuery a = do+  qe <- getQueryEnv+  runQuery qe a+++prepareCabalHelper :: (IOish m, GmEnv m, GmOut m, GmLog m) => m ()+prepareCabalHelper = do+  crdl <- cradle+  when (isCabalHelperProject $ cradleProject crdl) $+       withCabal $ prepare' =<< getQueryEnv++withAutogen :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a+withAutogen action = do+    gmLog GmDebug "" $ strDoc $ "making sure autogen files exist"+    crdl <- cradle+    let projdir = cradleRootDir crdl+        distdir = projdir </> cradleDistDir crdl++    (pkgName', _) <- runCHQuery packageId++    mCabalFile          <- liftIO $ timeFile `traverse` cradleCabalFile crdl+    mCabalMacroHeader   <- liftIO $ timeMaybe (distdir </> macrosHeaderPath)+    mCabalPathsModule   <- liftIO $ timeMaybe (distdir </> autogenModulePath pkgName')++    when (mCabalMacroHeader < mCabalFile || mCabalPathsModule < mCabalFile) $ do+      gmLog GmDebug "" $ strDoc $ "autogen files out of sync"+      writeAutogen++    action++ where+   writeAutogen = do+     gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files"+     writeAutogenFiles' =<< getQueryEnv+++withCabal :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a+withCabal action = do+    crdl <- cradle+    mCabalFile          <- liftIO $ timeFile `traverse` cradleCabalFile crdl+    mCabalConfig        <- liftIO $ timeMaybe (setupConfigFile crdl)+    mCabalSandboxConfig <- liftIO $ timeMaybe (sandboxConfigFile crdl)++    let haveSetupConfig = isJust mCabalConfig++    cusPkgDb <- getCustomPkgDbStack+    (flgs, pkgDbStackOutOfSync) <- do+      if haveSetupConfig+        then runCHQuery $ do+          flgs <- nonDefaultConfigFlags+          pkgDb <- map chPkgToGhcPkg <$> packageDbStack+          return (flgs, fromMaybe False $ (pkgDb /=) <$> cusPkgDb)+        else return ([], False)++    when (isSetupConfigOutOfDate mCabalFile mCabalConfig) $+      gmLog GmDebug "" $ strDoc $ "setup configuration is out of date"++    when (isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $+      gmLog GmDebug "" $ strDoc $ "sandbox configuration is out of date"++    when pkgDbStackOutOfSync $+      gmLog GmDebug "" $ strDoc $ "package-db stack out of sync with ghc-mod.package-db-stack"++    when ( isSetupConfigOutOfDate mCabalFile mCabalConfig+        || pkgDbStackOutOfSync+        || isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $ do+          proj <- cradleProject <$> cradle+          opts <- options+          case proj of+            CabalProject -> do+                gmLog GmDebug "" $ strDoc "reconfiguring Cabal project"+                cabalReconfigure (optPrograms opts) crdl flgs+            StackProject {} -> do+                gmLog GmDebug "" $ strDoc "reconfiguring Stack project"+                -- TODO: we could support flags for stack too, but it seems+                -- you're supposed to put those in stack.yaml so detecting which+                -- flags to pass down would be more difficult++                -- "--flag PACKAGE:[-]FLAG Override flags set in stack.yaml+                -- (applies to local packages and extra-deps)"++                stackReconfigure (optStackBuildDeps opts) crdl (optPrograms opts)+            _ ->+                error $ "withCabal: unsupported project type: " ++ show proj++    action++ where+   cabalReconfigure progs crdl flgs = do+     readProc <- gmReadProcess+     withDirectory_ (cradleRootDir crdl) $ do+        cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack+        let progOpts =+                [ "--with-ghc=" ++ T.ghcProgram progs ]+                -- Only pass ghc-pkg if it was actually set otherwise we+                -- might break cabal's guessing logic+                ++ if T.ghcPkgProgram progs /= T.ghcPkgProgram (optPrograms defaultOptions)+                     then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram progs ]+                     else []+                ++ map pkgDbArg cusPkgStack+                ++ flagOpt++            toFlag (f, True) = f+            toFlag (f, False) = '-':f+            flagOpt = ["--flags", unwords $ map toFlag flgs]++        liftIO $ void $ readProc (T.cabalProgram progs) ("configure":progOpts) ""+   stackReconfigure deps crdl progs = do+     withDirectory_ (cradleRootDir crdl) $ do+       supported <- haveStackSupport+       if supported+          then do+            when deps $+              spawn [T.stackProgram progs, "build", "--only-dependencies", "."]+            spawn [T.stackProgram progs, "build", "--only-configure", "."]+          else+            gmLog GmWarning "" $ strDoc $ "Stack project configuration is out of date, please reconfigure manually using 'stack build' as your stack version is too old (need at least 0.1.4.0)"++   spawn [] = return ()+   spawn (exe:args) = do+     readProc <- gmReadProcess+     liftIO $ void $ readProc exe args ""++   haveStackSupport = do+     (rv, _, _) <-+         liftIO $ readProcessWithExitCode "stack" ["--numeric-version"] ""+     case rv of+       ExitSuccess -> return True+       ExitFailure _ -> return False++++pkgDbArg :: GhcPkgDb -> String+pkgDbArg GlobalDb      = "--package-db=global"+pkgDbArg UserDb        = "--package-db=user"+pkgDbArg (PackageDb p) = "--package-db=" ++ p++-- * Neither file exists -> should return False:+--   @Nothing < Nothing = False@+--   (since we don't need to @cabal configure@ when no cabal file exists.)+--+-- * Cabal file doesn't exist (impossible since cabal-helper is only used with+-- cabal projects) -> should return False+--   @Just cc < Nothing = False@+--+-- * dist/setup-config doesn't exist yet -> should return True:+--   @Nothing < Just cf = True@+--+-- * Both files exist+--   @Just cc < Just cf = cc < cf = cc `olderThan` cf@+isSetupConfigOutOfDate :: Maybe TimedFile -> Maybe TimedFile -> Bool+isSetupConfigOutOfDate worldCabalFile worldCabalConfig = do+  worldCabalConfig < worldCabalFile++helperProgs :: Programs -> CH.Programs+helperProgs progs = CH.Programs {+    cabalProgram  = T.cabalProgram progs,+    ghcProgram    = T.ghcProgram progs,+    ghcPkgProgram = T.ghcPkgProgram progs+  }++chCached :: (Applicative m, IOish m, Gm m, Binary a)+  => (FilePath -> Cached m GhcModState ChCacheData a) -> m a+chCached c = do+  projdir <- cradleRootDir <$> cradle+  distdir <- (projdir </>) . cradleDistDir <$> cradle+  d <- cacheInputData projdir+  withCabal $ cached projdir (c distdir) d+ where+   -- we don't need to include the distdir in the cache input because when it+   -- changes the cache files will be gone anyways ;)+   cacheInputData projdir = do+               opts <- options+               crdl <- cradle+               progs' <- patchStackPrograms crdl (optPrograms opts)+               return $ ( helperProgs progs'+                        , projdir+                        , (showVersion gmVer, chVer)+                        )++   gmVer = GhcMod.version+   chVer = VERSION_cabal_helper
+ core/GhcMod/Caching.hs view
@@ -0,0 +1,141 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.+{-# LANGUAGE CPP, OverloadedStrings #-}+module GhcMod.Caching (+    module GhcMod.Caching+  , module GhcMod.Caching.Types+  ) where++import Control.Arrow (first)+import Control.Monad+import Control.Monad.Trans.Maybe+#if !MIN_VERSION_binary(0,7,0)+import Control.Exception+#endif+import Data.Maybe+import Data.Binary hiding (get)+import Data.Version+import Data.Label+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import System.FilePath+import System.Directory.ModTime+import Utils (TimedFile(..), timeMaybe, mightExist)+import Paths_ghc_mod (version)+import Prelude++import GhcMod.Monad.Types+import GhcMod.Caching.Types+import GhcMod.Logging++-- | Cache a MonadIO action with proper invalidation.+cached :: forall m a d. (Gm m, MonadIO m, Binary a, Eq d, Binary d, Show d)+       => FilePath -- ^ Directory to prepend to 'cacheFile'+       -> Cached m GhcModState d a -- ^ Cache descriptor+       -> d+       -> m a+cached dir cd d = do+    mcc <- readCache+    case mcc of+      Nothing -> do+          t <- liftIO $ getCurrentModTime+          writeCache (TimedCacheFiles t []) Nothing "cache missing or unreadable"+      Just (t, ifs, d', a) | d /= d' -> do+          tcfs <- timeCacheInput dir ifs+          writeCache (TimedCacheFiles t tcfs) (Just a) $ "input data changed" -- ++ "   was: " ++ show d ++ "  is: " ++ show d'+      Just (t, ifs, _, a) -> do+          tcfs <- timeCacheInput dir ifs+          case invalidatingInputFiles $ TimedCacheFiles t tcfs of+            [] -> return a+            _  -> writeCache (TimedCacheFiles t tcfs) (Just a) "input files changed"++ where+   cacheHeader = BS8.pack $ "Written by ghc-mod " ++ showVersion version ++ "\n"++   lbsToStrict = BS.concat . LBS.toChunks+   lbsFromStrict bs = LBS.fromChunks [bs]++   writeCache tcfs ma cause = do+     (ifs', a) <- (cachedAction cd) tcfs d ma+     t <- liftIO $ getCurrentModTime+     gmLog GmDebug "" $ (text "regenerating cache") <+>: text (cacheFile cd)+                                                    <+> parens (text cause)+     case cacheLens cd of+       Nothing -> return ()+       Just label -> do+         gmLog GmDebug "" $ (text "writing memory cache") <+>: text (cacheFile cd)+         setLabel label $ Just (t, ifs', d, a)++     let c = BS.append cacheHeader $ lbsToStrict $ encode (t, ifs', d, a)++     liftIO $ BS.writeFile (dir </> cacheFile cd) c++     return a++   setLabel l x = do+     s <- gmsGet+     gmsPut $ set l x s++   readCache :: m (Maybe (ModTime, [FilePath], d, a))+   readCache = runMaybeT $ do+       case cacheLens cd of+         Just label -> do+             c <- MaybeT (get label `liftM` gmsGet) `mplus` readCacheFromFile+             setLabel label $ Just c+             return c+         Nothing ->+             readCacheFromFile++   readCacheFromFile :: MaybeT m (ModTime, [FilePath], d, a)+   readCacheFromFile = do+         f <- MaybeT $ liftIO $ mightExist $ cacheFile cd+         readCacheFromFile' f++   readCacheFromFile' :: FilePath -> MaybeT m (ModTime, [FilePath], d, a)+   readCacheFromFile' f = MaybeT $ do+     gmLog GmDebug "" $ (text "reading cache") <+>: text (cacheFile cd)+     cc <- liftIO $ BS.readFile f+     case first BS8.words $ BS8.span (/='\n') cc of+       (["Written", "by", "ghc-mod", ver], rest)+           | BS8.unpack ver == showVersion version ->+            either (const Nothing) Just+                `liftM` decodeE (lbsFromStrict $ BS.drop 1 rest)+       _ -> return Nothing++   decodeE b = do+#if MIN_VERSION_binary(0,7,0)+     return $ case decodeOrFail b of+       Left (_rest, _offset, errmsg) -> Left errmsg+       Right (_reset, _offset, a) -> Right a+#else+     ea <- liftIO $ try $ evaluate $ decode b+     return $ case ea of+       Left (ErrorCall errmsg) -> Left errmsg+       Right a -> Right a++#endif++timeCacheInput :: MonadIO m => FilePath -> [FilePath] -> m [TimedFile]+timeCacheInput dir ifs = liftIO $ do+    ins <- (timeMaybe . (dir </>)) `mapM` ifs+    return $ catMaybes ins++invalidatingInputFiles :: TimedCacheFiles -> [FilePath]+invalidatingInputFiles (TimedCacheFiles tcreated tcfs) =+    map tfPath $+        -- get input files older than tcfile+        filter ((TimedFile "" tcreated)<) tcfs
+ core/GhcMod/Caching/Types.hs view
@@ -0,0 +1,67 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.+module GhcMod.Caching.Types where++import Utils+import Data.Label+import System.Directory.ModTime+import Distribution.Helper++type CacheContents d a = Maybe (ModTime, [FilePath], d, a)+type CacheLens s d a = s :-> CacheContents d a++data Cached m s d a = Cached {+  cacheFile       :: FilePath,+  cacheLens       :: Maybe (CacheLens s d a),+  cachedAction    :: TimedCacheFiles+                  -> d+                  -> Maybe a+                  -> m ([FilePath], a)++  -- ^ @cachedAction tcf data ma@+  --+  -- * @tcf@: Input file timestamps. Not technically necessary, just an+  -- optimizazion when knowing which input files changed can make updating the+  -- cache faster+  --+  -- * @data@: Arbitrary static input data to cache action. Can be used to+  -- invalidate the cache using something other than file timestamps+  -- i.e. environment tool version numbers+  --+  -- * @ma@: Cached data if it existed+  --+  -- Returns:+  --+  -- * @fst@: Input files used in generating the cache+  --+  -- * @snd@: Cache data, will be stored alongside the static input data in the+  --   'cacheFile'+  --+  -- The cached action, will only run if one of the following is true:+  --+  -- * 'cacheFile' doesn\'t exist yet+  -- * 'cacheFile' exists and 'inputData' changed+  -- * any files returned by the cached action changed+ }++data TimedCacheFiles = TimedCacheFiles {+  tcCreated :: ModTime,+  -- ^ 'cacheFile' timestamp+  tcFiles     :: [TimedFile]+  -- ^ Timestamped files returned by the cached action+ } deriving (Eq, Ord)++type ChCacheData = (Programs, FilePath, (String, String))
+ core/GhcMod/Convert.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-}++module GhcMod.Convert (convert, convert', emptyResult, whenFound, whenFound') where++import GhcMod.Monad.Types+import GhcMod.Types++import Control.Applicative+import Prelude++type Builder = String -> String++-- |+--+-- >>> replace '"' "\\\"" "foo\"bar" ""+-- "foo\\\"bar"+replace :: Char -> String -> String -> Builder+replace _ _  [] = id+replace c cs (x:xs)+  | x == c    = (cs ++) . replace c cs xs+  | otherwise = (x :) . replace c cs xs++inter :: Char -> [Builder] -> Builder+inter _ [] = id+inter c bs = foldr1 (\x y -> x . (c:) . y) bs++convert' :: (ToString a, IOish m, GmEnv m) => a -> m String+convert' x = flip convert x . optOutput <$> options++convert :: ToString a => OutputOpts -> a -> String+convert opt@OutputOpts { ooptStyle = LispStyle  } x = toLisp opt x "\n"+convert opt@OutputOpts { ooptStyle = PlainStyle } x+  | str == "\n" = ""+  | otherwise   = str+  where+    str = toPlain opt x "\n"++class ToString a where+  toLisp  :: OutputOpts -> a -> Builder+  toPlain :: OutputOpts -> a -> Builder++lineSep :: OutputOpts -> String+lineSep oopts = interpret lsep+  where+    interpret s = read $ "\"" ++ s ++ "\""+    LineSeparator lsep = ooptLineSeparator oopts++-- |+--+-- >>> toLisp (optOutput defaultOptions) "fo\"o" ""+-- "\"fo\\\"o\""+-- >>> toPlain (optOutput defaultOptions) "foo" ""+-- "foo"+instance ToString String where+  toLisp  oopts = quote oopts+  toPlain oopts = replace '\n' (lineSep oopts)++-- |+--+-- >>> toLisp (optOutput defaultOptions) ["foo", "bar", "ba\"z"] ""+-- "(\"foo\" \"bar\" \"ba\\\"z\")"+-- >>> toPlain (optOutput defaultOptions) ["foo", "bar", "baz"] ""+-- "foo\nbar\nbaz"+instance ToString [String] where+  toLisp  oopts = toSexp1 oopts+  toPlain oopts = inter '\n' . map (toPlain oopts)++instance ToString [ModuleString] where+  toLisp  oopts = toLisp oopts . map getModuleString+  toPlain oopts = toPlain oopts . map getModuleString++-- |+--+-- >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)]+-- >>> toLisp (optOutput defaultOptions) inp ""+-- "((1 2 3 4 \"foo\") (5 6 7 8 \"bar\"))"+-- >>> toPlain (optOutput defaultOptions) inp ""+-- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\""+instance ToString [((Int,Int,Int,Int),String)] where+  toLisp  oopts = toSexp2 . map toS+    where+      toS x = ('(' :) . tupToString oopts x . (')' :)+  toPlain oopts = inter '\n' . map (tupToString oopts)++instance ToString ((Int,Int,Int,Int),String) where+  toLisp  oopts x = ('(' :) . tupToString oopts x . (')' :)+  toPlain oopts x = tupToString oopts x++instance ToString ((Int,Int,Int,Int),[String]) where+  toLisp  oopts (x,s) = ('(' :) .  fourIntsToString x .+                        (' ' :) . toLisp oopts s . (')' :)+  toPlain oopts (x,s) = fourIntsToString x . ('\n' :) . toPlain oopts s++instance ToString (String, (Int,Int,Int,Int),[String]) where+  toLisp  oopts (s,x,y) = toSexp2 [toLisp oopts s, ('(' :) . fourIntsToString x . (')' :), toLisp oopts y]+  toPlain oopts (s,x,y) = inter '\n' [toPlain oopts s, fourIntsToString x, toPlain oopts y]++toSexp1 :: OutputOpts -> [String] -> Builder+toSexp1 oopts ss = ('(' :) . inter ' ' (map (quote oopts) ss) . (')' :)++toSexp2 :: [Builder] -> Builder+toSexp2 ss = ('(' :) . inter ' ' ss . (')' :)++fourIntsToString :: (Int,Int,Int,Int) -> Builder+fourIntsToString (a,b,c,d) = (show a ++) . (' ' :)+                           . (show b ++) . (' ' :)+                           . (show c ++) . (' ' :)+                           . (show d ++)++tupToString :: OutputOpts -> ((Int,Int,Int,Int),String) -> Builder+tupToString oopts ((a,b,c,d),s) = (show a ++) . (' ' :)+                                . (show b ++) . (' ' :)+                                . (show c ++) . (' ' :)+                                . (show d ++) . (' ' :)+                                . quote oopts s -- fixme: quote is not necessary++quote :: OutputOpts -> String -> Builder+quote oopts str = ("\"" ++) .  (quote' str ++) . ("\"" ++)+  where+    lsep = lineSep oopts+    quote' [] = []+    quote' (x:xs)+      | x == '\n' = lsep   ++ quote' xs+      | x == '\\' = "\\\\" ++ quote' xs+      | x == '"'  = "\\\"" ++ quote' xs+      | otherwise = x       : quote' xs++----------------------------------------------------------------++-- Empty result to be returned when no info can be gathered+emptyResult :: Monad m => OutputOpts -> m String+emptyResult oopts = return $ convert oopts ([] :: [String])++-- Return an emptyResult when Nothing+whenFound :: (Monad m, ToString b) => OutputOpts -> m (Maybe a) -> (a -> b) -> m String+whenFound oopts from f = maybe (emptyResult oopts) (return . convert oopts . f) =<< from++-- Return an emptyResult when Nothing, inside a monad+whenFound' :: (Monad m, ToString b) => OutputOpts -> m (Maybe a) -> (a -> m b) -> m String+whenFound' oopts from f = maybe (emptyResult oopts) (\x -> do y <- f x ; return (convert oopts y)) =<< from
+ core/GhcMod/Cradle.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE CPP #-}+module GhcMod.Cradle+  ( findCradle+  , findCradle'+  , findCradleNoLog+  , findSpecCradle+  , cleanupCradle++  -- * for @spec@+  , plainCradle+  ) where++import GhcMod.PathsAndFiles+import GhcMod.Monad.Types+import GhcMod.Types+import GhcMod.Utils+import GhcMod.Stack+import GhcMod.Logging+import GhcMod.Error++import Safe+import Control.Applicative+import Control.Monad.Trans.Maybe+import Data.Maybe+import System.Directory+import System.FilePath+import System.Environment+import Prelude+import Control.Monad.Trans.Journal (runJournalT)++----------------------------------------------------------------++-- | Finding 'Cradle'.+--   Find a cabal file by tracing ancestor directories.+--   Find a sandbox according to a cabal sandbox config+--   in a cabal directory.+findCradle :: (GmLog m, IOish m, GmOut m) => Programs -> m Cradle+findCradle progs = findCradle' progs =<< liftIO getCurrentDirectory++findCradleNoLog  :: forall m. (IOish m, GmOut m) => Programs -> m Cradle+findCradleNoLog progs =+    fst <$> (runJournalT (findCradle progs) :: m (Cradle, GhcModLog))++findCradle' :: (GmLog m, IOish m, GmOut m) => Programs -> FilePath -> m Cradle+findCradle' Programs { stackProgram, cabalProgram } dir = run $+    msum [ stackCradle stackProgram dir+         , cabalCradle cabalProgram dir+         , sandboxCradle dir+         , plainCradle dir+         ]+ where run a = fillTempDir =<< (fromJustNote "findCradle'" <$> runMaybeT a)++findSpecCradle ::+    (GmLog m, IOish m, GmOut m) => Programs -> FilePath -> m Cradle+findSpecCradle Programs { stackProgram, cabalProgram } dir = do+    let cfs = [ stackCradleSpec stackProgram+              , cabalCradle cabalProgram+              , sandboxCradle+              ]+    cs <- catMaybes <$> mapM (runMaybeT . ($ dir)) cfs+    gcs <- filterM isNotGmCradle cs+    fillTempDir =<< case gcs of+                      [] -> fromJust <$> runMaybeT (plainCradle dir)+                      c:_ -> return c+ where+   isNotGmCradle crdl =+     liftIO $ not <$> doesFileExist (cradleRootDir crdl </> "ghc-mod.cabal")++cleanupCradle :: Cradle -> IO ()+cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl++fillTempDir :: IOish m => Cradle -> m Cradle+fillTempDir crdl = do+  tmpDir <- liftIO $ newTempDir (cradleRootDir crdl)+  return crdl { cradleTempDir = tmpDir }++cabalCradle ::+    (IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle+cabalCradle cabalProg wdir = do+    cabalFile <- MaybeT $ liftIO $ findCabalFile wdir+    let cabalDir = takeDirectory cabalFile++    gmLog GmInfo "" $ text "Found Cabal project at" <+>: text cabalDir++    -- If cabal doesn't exist the user probably wants to use something else+    whenM ((==Nothing) <$> liftIO (findExecutable cabalProg)) $ do+      gmLog GmInfo "" $ text "'cabal' executable wasn't found, trying next project type"+      mzero++    gmLog GmInfo "" $ text "Using Cabal project at" <+>: text cabalDir+    return Cradle {+        cradleProject    = CabalProject+      , cradleCurrentDir = wdir+      , cradleRootDir    = cabalDir+      , cradleTempDir    = error "tmpDir"+      , cradleCabalFile  = Just cabalFile+      , cradleDistDir    = "dist"+      }++stackCradle ::+    (IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle+stackCradle stackProg wdir = do+#if __GLASGOW_HASKELL__ < 708+    -- GHC < 7.8 is not supported by stack+    mzero+#endif++    cabalFile <- MaybeT $ liftIO $ findCabalFile wdir+    let cabalDir = takeDirectory cabalFile+    _stackConfigFile <- MaybeT $ liftIO $ findStackConfigFile cabalDir++    gmLog GmInfo "" $ text "Found Stack project at" <+>: text cabalDir++    stackExeSet    <- liftIO $ isJust <$> lookupEnv "STACK_EXE"+    stackExeExists <- liftIO $ isJust <$> findExecutable stackProg+    setupCfgExists <- liftIO $ doesFileExist $ cabalDir </> setupConfigPath "dist"++    case (stackExeExists, stackExeSet) of+      (False, True) -> do+        gmLog GmWarning "" $ text "'stack' executable wasn't found but STACK_EXE is set, trying next project type"+        mzero++      (False, False) -> do+        gmLog GmInfo "" $ text "'stack' executable wasn't found, trying next project type"+        mzero++      (True, True) -> do+        gmLog GmInfo "" $ text "STACK_EXE set, preferring Stack project"++      (True, False) | setupCfgExists -> do+        gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack project"+        mzero++      (True, False) -> return ()++    senv <- MaybeT $ getStackEnv cabalDir stackProg++    gmLog GmInfo "" $ text "Using Stack project at" <+>: text cabalDir+    return Cradle {+        cradleProject    = StackProject senv+      , cradleCurrentDir = wdir+      , cradleRootDir    = cabalDir+      , cradleTempDir    = error "tmpDir"+      , cradleCabalFile  = Just cabalFile+      , cradleDistDir    = seDistDir senv+      }++stackCradleSpec ::+    (IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle+stackCradleSpec stackProg wdir = do+  crdl <- stackCradle stackProg wdir+  case crdl of+    Cradle { cradleProject = StackProject StackEnv { seDistDir } } -> do+      b <- isGmDistDir seDistDir+      when b mzero+      return crdl+    _ -> error "stackCradleSpec"+ where+   isGmDistDir dir =+       liftIO $ not <$> doesFileExist (dir </> ".." </> "ghc-mod.cabal")++sandboxCradle :: (IOish m, GmLog m, GmOut m) => FilePath -> MaybeT m Cradle+sandboxCradle wdir = do+    sbDir <- MaybeT $ liftIO $ findCabalSandboxDir wdir+    gmLog GmInfo "" $ text "Using sandbox project at" <+>: text sbDir+    return Cradle {+        cradleProject    = SandboxProject+      , cradleCurrentDir = wdir+      , cradleRootDir    = sbDir+      , cradleTempDir    = error "tmpDir"+      , cradleCabalFile  = Nothing+      , cradleDistDir    = "dist"+      }++plainCradle :: (IOish m, GmLog m, GmOut m) => FilePath -> MaybeT m Cradle+plainCradle wdir = do+    gmLog GmInfo "" $ text "Found no other project type, falling back to plain GHC project"+    return $ Cradle {+        cradleProject    = PlainProject+      , cradleCurrentDir = wdir+      , cradleRootDir    = wdir+      , cradleTempDir    = error "tmpDir"+      , cradleCabalFile  = Nothing+      , cradleDistDir    = "dist"+      }
+ core/GhcMod/CustomPackageDb.hs view
@@ -0,0 +1,38 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.+module GhcMod.CustomPackageDb where++import Control.Applicative+import Control.Monad+import Control.Category ((.))+import Data.Maybe+import Data.Traversable+import GhcMod.Types+import GhcMod.Monad.Types+import GhcMod.PathsAndFiles+import Prelude hiding ((.))++parseCustomPackageDb :: String -> [GhcPkgDb]+parseCustomPackageDb src = map parsePkgDb $ filter (not . null) $ lines src+ where+   parsePkgDb "global" = GlobalDb+   parsePkgDb "user" = UserDb+   parsePkgDb s = PackageDb s++getCustomPkgDbStack :: (MonadIO m, GmEnv m) => m (Maybe [GhcPkgDb])+getCustomPkgDbStack = do+    mCusPkgDbFile <- liftIO . (traverse readFile <=< findCustomPackageDbFile) . cradleRootDir =<< cradle+    return $ parseCustomPackageDb <$> mCusPkgDbFile
+ core/GhcMod/DebugLogger.hs view
@@ -0,0 +1,138 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.+{-# LANGUAGE CPP, RankNTypes #-}+module GhcMod.DebugLogger where++-- (c) The University of Glasgow 2005+--+-- The Glasgow Haskell Compiler License+--+-- Copyright 2002, The University Court of the University of Glasgow.+-- All rights reserved.+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:+--+-- - Redistributions of source code must retain the above copyright notice,+-- this list of conditions and the following disclaimer.+--+-- - Redistributions in binary form must reproduce the above copyright notice,+-- this list of conditions and the following disclaimer in the documentation+-- and/or other materials provided with the distribution.+--+-- - Neither name of the University nor the names of its contributors may be+-- used to endorse or promote products derived from this software without+-- specific prior written permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+-- GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+-- INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+-- FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+-- UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+-- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+-- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+-- DAMAGE.++import GHC+import FastString+import Pretty+import Outputable (SDoc, PprStyle, runSDoc, initSDocContext, blankLine)+import qualified Outputable+import ErrUtils++import GhcMod.Error+import GhcMod.Gap+import Prelude++debugLogAction :: (String -> IO ()) -> GmLogAction+debugLogAction putErr _reason dflags severity srcSpan style' msg+    = case severity of+      SevOutput      -> printSDoc putErr msg style'++#if __GLASGOW_HASKELL__ >= 706+      SevDump        -> printSDoc putErr (msg Outputable.$$ blankLine) style'+#endif++#if __GLASGOW_HASKELL__ >= 708+      SevInteractive -> let+          putStrSDoc = debugLogActionHPutStrDoc dflags putErr+       in+          putStrSDoc msg style'+#endif+      SevInfo        -> printErrs putErr msg style'+      SevFatal       -> printErrs putErr msg style'+      _              -> do putErr "\n"+#if __GLASGOW_HASKELL__ >= 706+                           printErrs putErr (mkLocMessage severity srcSpan msg) style'+#else+                           printErrs putErr (mkLocMessage srcSpan msg) style'+#endif+                           -- careful (#2302): printErrs prints in UTF-8,+                           -- whereas converting to string first and using+                           -- hPutStr would just emit the low 8 bits of+                           -- each unicode char.+    where+#if __GLASGOW_HASKELL__ >= 706+      printSDoc put = debugLogActionHPrintDoc  dflags put+      printErrs put = debugLogActionHPrintDoc  dflags put+#endif+++#if __GLASGOW_HASKELL__ >= 706++debugLogActionHPrintDoc :: DynFlags -> (String -> IO ()) -> SDoc -> PprStyle -> IO ()+debugLogActionHPrintDoc dflags put d sty+ = debugLogActionHPutStrDoc dflags put (d Outputable.$$ Outputable.text "") sty+      -- Adds a newline++debugLogActionHPutStrDoc :: DynFlags -> (String -> IO ()) -> SDoc -> PprStyle -> IO ()+debugLogActionHPutStrDoc dflags put d sty+  = gmPrintDoc_ Pretty.PageMode (pprCols dflags) put doc+  where   -- Don't add a newline at the end, so that successive+          -- calls to this log-action can output all on the same line+    doc = runSDoc d (initSDocContext dflags sty)++#else++printSDoc = printErrs++printErrs :: (String -> IO ()) -> SDoc -> PprStyle -> IO ()+printErrs put doc sty = do+  gmPrintDoc PageMode 100 put (runSDoc doc (initSDocContext sty))++#endif++gmPrintDoc :: Mode -> Int -> (String -> IO ()) -> Doc -> IO ()+-- printDoc adds a newline to the end+gmPrintDoc mode cols put doc = gmPrintDoc_ mode cols put (doc $$ text "")++gmPrintDoc_ :: Mode -> Int -> (String -> IO ()) -> Doc -> IO ()+gmPrintDoc_ mode pprCols putS doc+  = fullRender mode pprCols 1.5 put done doc+  where+    put (Chr c)  next = putS [c] >> next+    put (Str s)  next = putS s >> next+    put (PStr s) next = putS (unpackFS s) >> next+#if __GLASGOW_HASKELL__ >= 708+    put (ZStr s) next = putS (zString s) >> next+#endif+    put (LStr s _l) next = putS (unpackLitString s) >> next++    done = return () -- hPutChar hdl '\n'
+ core/GhcMod/Doc.hs view
@@ -0,0 +1,20 @@+module GhcMod.Doc where++import GHC+import GhcMod.Gap (withStyle, showDocWith)+import Outputable+import Pretty (Mode(..))++showPage :: DynFlags -> PprStyle -> SDoc -> String+showPage dflag style = showDocWith dflag PageMode . withStyle dflag style++showOneLine :: DynFlags -> PprStyle -> SDoc -> String+showOneLine dflag style = showDocWith dflag OneLineMode . withStyle dflag style++getStyle :: GhcMonad m => m PprStyle+getStyle = do+    unqual <- getPrintUnqual+    return $ mkUserStyle unqual AllTheWay++styleUnqualified :: PprStyle+styleUnqualified = mkUserStyle neverQualify AllTheWay
+ core/GhcMod/DynFlags.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE TemplateHaskell #-}++module GhcMod.DynFlags where++import Control.Applicative+import Control.Monad+import GHC+import qualified GHC as G+import GHC.Paths (libdir)+import qualified GhcMod.Gap as Gap+import GhcMod.Types+import GhcMod.DebugLogger+import GhcMod.DynFlagsTH+import System.IO.Unsafe (unsafePerformIO)+import Prelude++setEmptyLogger :: DynFlags -> DynFlags+setEmptyLogger df =+    Gap.setLogAction df $ \_ _ _ _ _ _ -> return ()++setDebugLogger :: (String -> IO ()) -> DynFlags -> DynFlags+setDebugLogger put df = do+  Gap.setLogAction df (debugLogAction put)++-- * Fast+-- * Friendly to foreign export+-- * Not friendly to -XTemplateHaskell and -XPatternSynonyms+-- * Uses little memory+setHscNothing :: DynFlags -> DynFlags+setHscNothing df = df {+    ghcMode   = CompManager+  , ghcLink   = NoLink+  , hscTarget = HscNothing+  , optLevel  = 0+  }++-- * Slow+-- * Not friendly to foreign export+-- * Friendly to -XTemplateHaskell and -XPatternSynonyms+-- * Uses lots of memory+setHscInterpreted :: DynFlags -> DynFlags+setHscInterpreted df = df {+    ghcMode   = CompManager+  , ghcLink   = LinkInMemory+  , hscTarget = HscInterpreted+  , optLevel  = 0+  }++-- | Parse command line ghc options and add them to the 'DynFlags' passed+addCmdOpts :: GhcMonad m => [GHCOption] -> DynFlags -> m DynFlags+addCmdOpts cmdOpts df =+    fst3 <$> G.parseDynamicFlags df (map G.noLoc cmdOpts)+  where+    fst3 (a,_,_) = a++----------------------------------------------------------------++withDynFlags :: GhcMonad m+             => (DynFlags -> DynFlags)+             -> m a+             -> m a+withDynFlags setFlags body = G.gbracket setup teardown (\_ -> body)+  where+    setup = do+        dflags <- G.getSessionDynFlags+        void $ G.setSessionDynFlags (setFlags dflags)+        return dflags+    teardown = void . G.setSessionDynFlags++withCmdFlags :: GhcMonad m => [GHCOption] -> m a -> m a+withCmdFlags flags body = G.gbracket setup teardown (\_ -> body)+  where+    setup = do+        dflags <- G.getSessionDynFlags+        void $ G.setSessionDynFlags =<< addCmdOpts flags dflags+        return dflags+    teardown = void . G.setSessionDynFlags++----------------------------------------------------------------++-- | Set 'DynFlags' equivalent to "-w:".+setNoWarningFlags :: DynFlags -> DynFlags+setNoWarningFlags df = df { warningFlags = Gap.emptyWarnFlags}++-- | Set 'DynFlags' equivalent to "-Wall".+setAllWarningFlags :: DynFlags -> DynFlags+setAllWarningFlags df = df { warningFlags = allWarningFlags }++allWarningFlags :: Gap.WarnFlags+allWarningFlags = unsafePerformIO $+    G.runGhc (Just libdir) $ do+        df <- G.getSessionDynFlags+        df' <- addCmdOpts ["-Wall"] df+        return $ G.warningFlags df'++----------------------------------------------------------------++deferErrors :: Monad m => DynFlags -> m DynFlags+deferErrors df = return $+  Gap.setWarnTypedHoles $ Gap.setDeferTypedHoles $+  Gap.setDeferTypeErrors $ setNoWarningFlags df++----------------------------------------------------------------++deriveEqDynFlags [d|+  eqDynFlags :: DynFlags -> DynFlags -> Bool+  eqDynFlags = undefined+ |]
+ core/GhcMod/DynFlagsTH.hs view
@@ -0,0 +1,144 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP, TemplateHaskell #-}+module GhcMod.DynFlagsTH where++import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Control.Applicative+import Data.Maybe+import Data.Generics.Aliases+import Data.Generics.Schemes+import DynFlags+import Prelude++deriveEqDynFlags :: Q [Dec] -> Q [Dec]+deriveEqDynFlags qds = do+#if __GLASGOW_HASKELL__ <= 710+  ~(TyConI (DataD [] _ [] [ctor] _ ))+#else+  ~(TyConI (DataD [] _ [] _ [ctor] _ ))+#endif+      <- reify ''DynFlags+  let ~(RecC _ fs) = ctor++  a <- newName "a"+  b <- newName "b"++  e <- AppE (VarE 'and) . ListE <$> sequence (catMaybes $ map (eq a b) fs)++  tysig@(SigD n _) :_ <- qds++  return $ [tysig, FunD n [Clause [VarP a, VarP b] (NormalB e) []]]++ where+   eq :: Name -> Name -> (Name, Strict, Type) -> Maybe (Q Exp)+   eq a b (fun@(Name (OccName fon) _), _, ft)+       | not (isUneqable || isIgnored) = Just expr+       | otherwise = Nothing+    where+       isUneqable = everything (||) (mkQ False hasUnEqable) ft++       hasUnEqable (AppT (ConT (Name (OccName on) _)) _)+           | any (==on) ignoredConstructorNames = True+       hasUnEqable (ConT (Name (OccName on) _))+           | any (==on) ignoredTypeNames = True+           | any (==on) ignoredTypeOccNames = True+       hasUnEqable _ = False++       isIgnored = fon `elem` ignoredNames++       ignoredConstructorNames = [ "IORef" ]++       ignoredNames = [ "pkgDatabase" -- 7.8+#if __GLASGOW_HASKELL__ <= 706+                      , "ways" -- 'Ways' is not exported :/+#endif+                      ]+       ignoredTypeNames =+           [ "LogAction"+           , "PackageState"+           , "Hooks"+           , "FlushOut"+           , "FlushErr"+           , "Settings" -- I think these can't cange at runtime+           ]+       ignoredTypeOccNames = [ "OnOff" ]++       fa = AppE (VarE fun) (VarE a)+       fb = AppE (VarE fun) (VarE b)+       expr =+         case fon of+           "rtsOptsEnabled" -> do+               let eqfn = [| let fn RtsOptsNone RtsOptsNone = True+                                 fn RtsOptsSafeOnly RtsOptsSafeOnly = True+                                 fn RtsOptsAll RtsOptsAll = True+                                 fn _ _ = False+                             in fn+                          |]+               [e| $(eqfn) $(return fa) $(return fb) |]++           "extraPkgConfs" -> do+               let eqfn = [| let fn a' b' = and (zipWith eqpr (a' []) (b' []))+                                        && length (a' []) == length (b' [])+                                 eqpr GlobalPkgConf GlobalPkgConf = True+                                 eqpr UserPkgConf UserPkgConf = True+                                 eqpr (PkgConfFile pa) (PkgConfFile pb) = pa == pb+                                 eqpr _ _ = False+                             in fn+                          |]+               [e| $(eqfn) $(return fa) $(return fb) |]++#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 800+           "sigOf" -> do+               let eqfn = [| let fn NotSigOf NotSigOf = True+                                 fn (SigOf a') (SigOf b') = a' == b'+                                 fn (SigOfMap a') (SigOfMap b') = a' == b'+                                 fn _ _ = False+                             in fn+                          |]+               [e| $(eqfn) $(return fa) $(return fb) |]+#endif++#if __GLASGOW_HASKELL <= 706+           "profAuto" -> do+               let eqfn = [| let fn NoProfAuto NoProfAuto = True+                                 fn ProfAutoAll ProfAutoAll = True+                                 fn ProfAutoTop ProfAutoTop = True+                                 fn ProfAutoExports ProfAutoExports = True+                                 fn ProfAutoCalls ProfAutoCalls = True+                                 fn _ _ = False+                             in fn+                          |]+               [e| $(eqfn) $(return fa) $(return fb) |]+#endif++#if __GLASGOW_HASKELL__ >= 706+           "language" -> do+               let eqfn = [| let fn (Just Haskell98) (Just Haskell98) = True+                                 fn (Just Haskell2010) (Just Haskell2010) = True+                                 fn Nothing Nothing = True+                                 fn _ _ = False+                             in fn+                          |]+               [e| $(eqfn) $(return fa) $(return fb) |]+#endif++           _ ->+               [e| $(return fa) == $(return fb)  |]++--       expr' = [e| trace (if $(expr) == True then "" else show ($(litE $ StringL fon), $(expr))) $(expr) |]
+ core/GhcMod/Error.hs view
@@ -0,0 +1,160 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE ExistentialQuantification #-}+module GhcMod.Error (+    GhcModError(..)+  , GmError+  , gmeDoc+  , ghcExceptionDoc+  , liftMaybe+  , overrideError+  , modifyError+  , modifyError'+  , modifyGmError+  , tryFix+  , GHandler(..)+  , gcatches+  , module Control.Monad.Error+  , module Control.Exception+  ) where++import Control.Arrow hiding ((<+>))+import Control.Exception+import Control.Monad.Error hiding (MonadIO, liftIO)+import qualified Data.Set as Set+import Data.List+import Data.Version+import System.Process (showCommandForUser)+import Text.Printf++import Exception+import Panic+import Pretty+import Config (cProjectVersion, cHostPlatformString)+import Paths_ghc_mod (version)++import GhcMod.Types+import GhcMod.Pretty++type GmError m = MonadError GhcModError m++gmeDoc :: GhcModError -> Doc+gmeDoc e = case e of+    GMENoMsg ->+        text "Unknown error"+    GMEString msg ->+        text msg+    GMECabalConfigure msg ->+        text "Configuring cabal project failed" <+>: gmeDoc msg+    GMEStackConfigure msg ->+        text "Configuring stack project failed" <+>: gmeDoc msg+    GMEStackBootstrap msg ->+        text "Bootstrapping stack project environment failed" <+>: gmeDoc msg+    GMECabalCompAssignment ctx ->+        text "Could not find a consistent component assignment for modules:" $$+          (nest 4 $ foldr ($+$) empty $ map ctxDoc ctx) $$+        text "" $$+        (if all (Set.null . snd) ctx+           then noComponentSuggestions+           else empty) $$+        text "- To find out which components ghc-mod knows about try:" $$+            nest 4 (backticks $ text "ghc-mod debug")++      where+        noComponentSuggestions =+          text "- Are some of these modules part of a test and or benchmark?\+               \ Try enabling them:" $$+              nest 4 (backticks $ text "cabal configure --enable-tests [--enable-benchmarks]")++        backticks d = char '`' <> d <> char '`'+        ctxDoc = moduleDoc *** compsDoc+                 >>> first (<> colon) >>> uncurry (flip hang 4)++        moduleDoc (Left fn)   =+            text "File " <> quotes (text fn)+        moduleDoc (Right mdl) =+            text "Module " <> quotes (text $ moduleNameString mdl)++        compsDoc sc | Set.null sc = text "has no known components"+        compsDoc sc = fsep $ punctuate comma $+                        map gmComponentNameDoc $ Set.toList sc+    GMEProcess _fn cmd args emsg -> let c = showCommandForUser cmd args in+        case emsg of+          Right err ->+             text (printf "Launching system command `%s` failed: " c)+                  <> gmeDoc err+          Left rv -> text $+             printf "Launching system command `%s` failed (exited with %d)" c rv+    GMENoCabalFile ->+        text "No cabal file found."+    GMETooManyCabalFiles cfs ->+        text $ "Multiple cabal files found. Possible cabal files: \""+               ++ intercalate "\", \"" cfs ++"\"."++ghcExceptionDoc :: GhcException -> Doc+ghcExceptionDoc e@(CmdLineError _) =+    text $ "<command line>: " ++ showGhcException e ""+ghcExceptionDoc (UsageError str) = strDoc str+ghcExceptionDoc (Panic msg) = vcat $ map text $ lines $ printf "\+\GHC panic! (the 'impossible' happened)\n\+\  ghc-mod version %s\n\+\  GHC library version %s for %s:\n\+\       %s\n\+\\n\+\Please report this as a bug: %s\n"+    gmVer ghcVer platform msg url+ where+   gmVer = showVersion version+   ghcVer = cProjectVersion+   platform = cHostPlatformString+   url = "https://github.com/kazu-yamamoto/ghc-mod/issues" :: String++ghcExceptionDoc e = text $ showGhcException e ""++liftMaybe :: MonadError e m => e -> m (Maybe a) -> m a+liftMaybe e action = maybe (throwError e) return =<< action++overrideError :: MonadError e m => e -> m a -> m a+overrideError e action = modifyError (const e) action++modifyError :: MonadError e m => (e -> e) -> m a -> m a+modifyError f action = action `catchError` \e -> throwError $ f e++infixr 0 `modifyError'`+modifyError' :: MonadError e m => m a -> (e -> e) -> m a+modifyError' = flip modifyError++modifyGmError :: (MonadIO m, ExceptionMonad m)+              => (GhcModError -> GhcModError) -> m a -> m a+modifyGmError f a = gcatch a $ \(ex :: GhcModError) -> liftIO $ throwIO (f ex)++tryFix :: MonadError e m => m a -> (e -> m ()) -> m a+tryFix action f = do+  action `catchError` \e -> f e >> action++data GHandler m a = forall e . Exception e => GHandler (e -> m a)++gcatches :: (MonadIO m, ExceptionMonad m) => m a -> [GHandler m a] -> m a+gcatches io handlers = io `gcatch` gcatchesHandler handlers++gcatchesHandler :: (MonadIO m, ExceptionMonad m)+    => [GHandler m a] -> SomeException -> m a+gcatchesHandler handlers e = foldr tryHandler (liftIO $ throw e) handlers+    where tryHandler (GHandler handler) res+              = case fromException e of+                Just e' -> handler e'+                Nothing -> res
+ core/GhcMod/FileMapping.hs view
@@ -0,0 +1,104 @@+module GhcMod.FileMapping+    ( loadMappedFile+    , loadMappedFileSource+    , unloadMappedFile+    , mapFile+    , fileModSummaryWithMapping+    ) where++import GhcMod.Types+import GhcMod.Monad.Types+import GhcMod.Gap+import GhcMod.HomeModuleGraph+import GhcMod.Utils++import System.IO+import System.FilePath+import System.Directory++import Control.Monad.Trans.Maybe+import GHC+import Control.Monad++{- | maps 'FilePath', given as first argument to take source from+'FilePath' given as second argument. Works exactly the same as+first form of `--map-file` CLI option.++\'from\' can be either full path, or path relative to project root.+\'to\' has to be either relative to project root, or full path (preferred)+-}+loadMappedFile :: IOish m+               => FilePath -- ^ \'from\', file that will be mapped+               -> FilePath -- ^ \'to\', file to take source from+               -> GhcModT m ()+loadMappedFile from to = loadMappedFile' from to False++{- |+maps 'FilePath', given as first argument to have source as given+by second argument.++\'from\' may or may not exist, and should be either full path,+or relative to project root.+-}+loadMappedFileSource :: IOish m+                     => FilePath -- ^ \'from\', file that will be mapped+                     -> String -- ^ \'src\', source+                     -> GhcModT m ()+loadMappedFileSource from src = do+  tmpdir <- cradleTempDir `fmap` cradle+  enc <- liftIO . mkTextEncoding . optEncoding =<< options+  to <- liftIO $ do+    (fn, h) <- openTempFile tmpdir (takeFileName from)+    hSetEncoding h enc+    hPutStr h src+    hClose h+    return fn+  loadMappedFile' from to True++loadMappedFile' :: IOish m => FilePath -> FilePath -> Bool -> GhcModT m ()+loadMappedFile' from to isTemp = do+  cfn <- getCanonicalFileNameSafe from+  unloadMappedFile' cfn+  crdl <- cradle+  let to' = makeRelative (cradleRootDir crdl) to+  addMMappedFile cfn (FileMapping to' isTemp)++mapFile :: (IOish m, GmState m) => HscEnv -> Target -> m Target+mapFile _ (Target tid@(TargetFile filePath _) taoc _) = do+  mapping <- lookupMMappedFile filePath+  return $ mkMappedTarget (Just filePath) tid taoc mapping+mapFile env (Target tid@(TargetModule moduleName) taoc _) = do+  (fp, mapping) <- do+    filePath <- fmap (fmap mpPath) (liftIO $ findModulePath env moduleName)+    mmf <- runMaybeT $ MaybeT (return filePath) >>= MaybeT . lookupMMappedFile+    return (filePath, mmf)+  return $ mkMappedTarget fp tid taoc mapping++mkMappedTarget :: Maybe FilePath -> TargetId -> Bool -> Maybe FileMapping -> Target+mkMappedTarget _ _ taoc (Just to) =+  mkTarget (TargetFile (fmPath to) Nothing) taoc Nothing+mkMappedTarget _ tid taoc _ =+  mkTarget tid taoc Nothing++{-|+unloads previously mapped file \'file\', so that it's no longer mapped,+and removes any temporary files created when file was+mapped.++\'file\' should be either full path, or relative to project root.+-}+unloadMappedFile :: IOish m+                 => FilePath -- ^ \'file\', file to unmap+                 -> GhcModT m ()+unloadMappedFile = getCanonicalFileNameSafe >=> unloadMappedFile'++unloadMappedFile' :: IOish m => FilePath -> GhcModT m ()+unloadMappedFile' cfn = void $ runMaybeT $ do+  fm <- MaybeT $ lookupMMappedFile cfn+  liftIO $ when (fmTemp fm) $ removeFile (fmPath fm)+  delMMappedFile cfn++fileModSummaryWithMapping :: (IOish m, GmState m, GhcMonad m, GmEnv m) =>+                            FilePath -> m ModSummary+fileModSummaryWithMapping fn =+  withMappedFile fn $ \fn' -> fileModSummary fn'
+ core/GhcMod/Gap.hs view
@@ -0,0 +1,723 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP, ScopedTypeVariables, RankNTypes #-}++module GhcMod.Gap (+    GhcMod.Gap.ClsInst+  , mkTarget+  , withStyle+  , GmLogAction+  , setLogAction+  , getSrcSpan+  , getSrcFile+  , withInteractiveContext+  , ghcCmdOptions+  , toStringBuffer+  , showSeverityCaption+  , setCabalPkg+  , setHideAllPackages+  , setDeferTypeErrors+  , setDeferTypedHoles+  , setWarnTypedHoles+  , setDumpSplices+  , setNoMaxRelevantBindings+  , isDumpSplices+  , filterOutChildren+  , infoThing+  , pprInfo+  , HasType(..)+  , errorMsgSpan+  , setErrorMsgSpan+  , typeForUser+  , nameForUser+  , occNameForUser+  , deSugar+  , showDocWith+  , renderGm+  , GapThing(..)+  , fromTyThing+  , fileModSummary+  , WarnFlags+  , emptyWarnFlags+  , GLMatch+  , GLMatchI+  , getClass+  , occName+  , listVisibleModuleNames+  , listVisibleModules+  , lookupModulePackageInAllPackages+  , GhcMod.Gap.isSynTyCon+  , parseModuleHeader+  , mkErrStyle'+  , everythingStagedWithContext+  , withCleanupSession+  ) where++import Control.Applicative hiding (empty)+import Control.Monad (filterM)+import CoreSyn (CoreExpr)+import Data.List (intersperse)+import Data.Maybe (catMaybes)+import Data.Time.Clock (UTCTime)+import Data.Traversable hiding (mapM)+import DataCon (dataConUserType)+import Desugar (deSugarExpr)+import DynFlags+import ErrUtils+import Exception+import FastString+import GhcMonad+import HscTypes+import NameSet+import OccName+import Outputable+import PprTyThing+import StringBuffer+import TcType+import Var (varType)+import System.Directory+import SysTools+#if __GLASGOW_HASKELL__ >= 800+import GHCi (stopIServ)+#endif++import qualified Name+import qualified InstEnv+import qualified Pretty+import qualified StringBuffer as SB++#if __GLASGOW_HASKELL__ >= 710+import CoAxiom (coAxiomTyCon)+#endif++#if __GLASGOW_HASKELL__ >= 708+import FamInstEnv+import ConLike (ConLike(..))+import PatSyn+#else+import TcRnTypes+#endif++-- GHC 7.8 doesn't define this macro, nor does GHC 7.10.0+-- It IS defined from 7.10.1 and up though.+-- So we can only test for 7.10.1.0 and up with it.+#if __GLASGOW_HASKELL__ < 710+#ifndef MIN_VERSION_GLASGOW_HASKELL+#define MIN_VERSION_GLASGOW_HASKELL(a,b,c,d) FALSE+#endif+#endif++#if MIN_VERSION_GLASGOW_HASKELL(8,0,1,20161117)+import GHC hiding (ClsInst, withCleanupSession)+import qualified GHC (withCleanupSession)+#elif __GLASGOW_HASKELL__ >= 706+import GHC hiding (ClsInst)+#else+import GHC hiding (Instance)+import Control.Arrow hiding ((<+>))+import Data.Convertible+import RdrName (rdrNameOcc)+#endif++#if __GLASGOW_HASKELL__ < 710+import UniqFM (eltsUFM)+import Module+#endif++#if __GLASGOW_HASKELL__ >= 704+import qualified Data.IntSet as I (IntSet, empty)+#endif++#if __GLASGOW_HASKELL__ < 706+import Control.DeepSeq (NFData(rnf))+import Data.ByteString.Lazy.Internal (ByteString(..))+#endif++import Bag+import Lexer as L+import Parser+import SrcLoc+import Packages+import Data.Generics (GenericQ, extQ, gmapQ)+import GHC.SYB.Utils (Stage(..))++import GhcMod.Types (Expression(..))+import Prelude++----------------------------------------------------------------+----------------------------------------------------------------+--+#if __GLASGOW_HASKELL__ >= 706+type ClsInst = InstEnv.ClsInst+#else+type ClsInst = InstEnv.Instance+#endif++mkTarget :: TargetId -> Bool -> Maybe (SB.StringBuffer, UTCTime) -> Target+#if __GLASGOW_HASKELL__ >= 706+mkTarget = Target+#else+mkTarget tid allowObjCode = Target tid allowObjCode . (fmap . second) convert+#endif++----------------------------------------------------------------+----------------------------------------------------------------++withStyle :: DynFlags -> PprStyle -> SDoc -> Pretty.Doc+#if __GLASGOW_HASKELL__ >= 706+withStyle = withPprStyleDoc+#else+withStyle _ = withPprStyleDoc+#endif++#if __GLASGOW_HASKELL__ >= 800+-- flip LogAction+type GmLogAction = WarnReason -> DynFlags -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()+#elif __GLASGOW_HASKELL__ >= 706+type GmLogAction = forall a. a -> LogAction+#else+type GmLogAction = forall a. a -> DynFlags -> LogAction+#endif++--  DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()++setLogAction :: DynFlags -> GmLogAction -> DynFlags+setLogAction df f =+#if __GLASGOW_HASKELL__ >= 800+    df { log_action = flip f }+#elif __GLASGOW_HASKELL__ >= 706+    df { log_action = f (error "setLogAction") }+#else+    df { log_action = f (error "setLogAction") df }+#endif++showDocWith :: DynFlags -> Pretty.Mode -> Pretty.Doc -> String+#if __GLASGOW_HASKELL__ >= 800+showDocWith dflags mode = Pretty.renderStyle mstyle where+    mstyle = Pretty.style { Pretty.mode = mode, Pretty.lineLength = pprCols dflags }+#elif __GLASGOW_HASKELL__ >= 708+-- Pretty.showDocWith disappeard.+-- https://github.com/ghc/ghc/commit/08a3536e4246e323fbcd8040e0b80001950fe9bc+showDocWith dflags mode = Pretty.showDoc mode (pprCols dflags)+#else+showDocWith _ = Pretty.showDocWith+#endif++renderGm :: Pretty.Doc -> String+#if __GLASGOW_HASKELL__ >= 800+renderGm = Pretty.fullRender Pretty.PageMode 80 1.2 string_txt ""+#else+renderGm = Pretty.fullRender Pretty.PageMode 80 1.2 string_txt ""+#endif+ where+   string_txt :: Pretty.TextDetails -> String -> String+   string_txt (Pretty.Chr c)   s  = c:s+   string_txt (Pretty.Str s1)  s2 = s1 ++ s2+   string_txt (Pretty.PStr s1) s2 = unpackFS s1 ++ s2+   string_txt (Pretty.LStr s1 _) s2 = unpackLitString s1 ++ s2+#if __GLASGOW_HASKELL__ >= 708+   string_txt (Pretty.ZStr s1) s2 = zString s1 ++ s2+#endif+++----------------------------------------------------------------+----------------------------------------------------------------++getSrcSpan :: SrcSpan -> Maybe (Int,Int,Int,Int)+#if __GLASGOW_HASKELL__ >= 702+getSrcSpan (RealSrcSpan spn)+#else+getSrcSpan spn | isGoodSrcSpan spn+#endif+             = Just (srcSpanStartLine spn+                   , srcSpanStartCol spn+                   , srcSpanEndLine spn+                   , srcSpanEndCol spn)+getSrcSpan _ = Nothing++getSrcFile :: SrcSpan -> Maybe String+#if __GLASGOW_HASKELL__ >= 702+getSrcFile (RealSrcSpan spn)       = Just . unpackFS . srcSpanFile $ spn+#else+getSrcFile spn | isGoodSrcSpan spn = Just . unpackFS . srcSpanFile $ spn+#endif+getSrcFile _ = Nothing++----------------------------------------------------------------++toStringBuffer :: GhcMonad m => [String] -> m StringBuffer+#if __GLASGOW_HASKELL__ >= 702+toStringBuffer = return . stringToStringBuffer . unlines+#else+toStringBuffer = liftIO . stringToStringBuffer . unlines+#endif++----------------------------------------------------------------++ghcCmdOptions :: [String]+#if __GLASGOW_HASKELL__ >= 710+-- this also includes -X options and all sorts of other things so the+ghcCmdOptions = flagsForCompletion False+#else+ghcCmdOptions = [ "-f" ++ prefix ++ option+                | option <- opts+                , prefix <- ["","no-"]+                ]+#  if __GLASGOW_HASKELL__ >= 704+ where opts =+           [option | (option,_,_) <- fFlags]+        ++ [option | (option,_,_) <- fWarningFlags]+        ++ [option | (option,_,_) <- fLangFlags]+#  else+ where opts =+           [option | (option,_,_,_) <- fFlags]+        ++ [option | (option,_,_,_) <- fWarningFlags]+        ++ [option | (option,_,_,_) <- fLangFlags]+#  endif+#endif++----------------------------------------------------------------+----------------------------------------------------------------++fileModSummary :: GhcMonad m => FilePath -> m ModSummary+fileModSummary file' = do+    mss <- getModuleGraph+    file <- liftIO $ canonicalizePath file'+    [ms] <- liftIO $ flip filterM mss $ \m ->+        (Just file==) <$> canonicalizePath `traverse` ml_hs_file (ms_location m)+    return ms++withInteractiveContext :: GhcMonad m => m a -> m a+withInteractiveContext action = gbracket setup teardown body+  where+    setup = getContext+    teardown = setCtx+    body _ = do+        topImports >>= setCtx+        action+    topImports = do+        ms <- filterM moduleIsInterpreted =<< map ms_mod <$> getModuleGraph+        let iis = map (IIModule . modName) ms+#if __GLASGOW_HASKELL__ >= 704+        return iis+#else+        return (iis,[])+#endif+#if __GLASGOW_HASKELL__ >= 706+    modName = moduleName+    setCtx = setContext+#elif __GLASGOW_HASKELL__ >= 704+    modName = id+    setCtx = setContext+#else+    modName = ms_mod+    setCtx = uncurry setContext+#endif++showSeverityCaption :: Severity -> String+#if __GLASGOW_HASKELL__ >= 706+showSeverityCaption SevWarning = "Warning: "+showSeverityCaption _          = ""+#else+showSeverityCaption = const ""+#endif++----------------------------------------------------------------+----------------------------------------------------------------++setCabalPkg :: DynFlags -> DynFlags+#if __GLASGOW_HASKELL__ >= 708+setCabalPkg dflag = gopt_set dflag Opt_BuildingCabalPackage+#else+setCabalPkg dflag = dopt_set dflag Opt_BuildingCabalPackage+#endif++----------------------------------------------------------------++setHideAllPackages :: DynFlags -> DynFlags+#if __GLASGOW_HASKELL__ >= 708+setHideAllPackages df = gopt_set df Opt_HideAllPackages+#else+setHideAllPackages df = dopt_set df Opt_HideAllPackages+#endif++----------------------------------------------------------------++setDumpSplices :: DynFlags -> DynFlags+setDumpSplices dflag = dopt_set dflag Opt_D_dump_splices++isDumpSplices :: DynFlags -> Bool+isDumpSplices dflag = dopt Opt_D_dump_splices dflag++----------------------------------------------------------------+++setDeferTypeErrors :: DynFlags -> DynFlags+#if __GLASGOW_HASKELL__ >= 708+setDeferTypeErrors dflag = gopt_set dflag Opt_DeferTypeErrors+#elif __GLASGOW_HASKELL__ >= 706+setDeferTypeErrors dflag = dopt_set dflag Opt_DeferTypeErrors+#else+setDeferTypeErrors = id+#endif++setDeferTypedHoles :: DynFlags -> DynFlags+#if __GLASGOW_HASKELL__ >= 710+setDeferTypedHoles dflag = gopt_set dflag Opt_DeferTypedHoles+#else+setDeferTypedHoles = id+#endif++setWarnTypedHoles :: DynFlags -> DynFlags+#if __GLASGOW_HASKELL__ >= 708+setWarnTypedHoles dflag = wopt_set dflag Opt_WarnTypedHoles+#else+setWarnTypedHoles = id+#endif++----------------------------------------------------------------++-- | Set 'DynFlags' equivalent to "-fno-max-relevant-bindings".+setNoMaxRelevantBindings :: DynFlags -> DynFlags+#if __GLASGOW_HASKELL__ >= 708+setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing }+#else+setNoMaxRelevantBindings = id+#endif++----------------------------------------------------------------+----------------------------------------------------------------++class HasType a where+    getType :: GhcMonad m => TypecheckedModule -> a -> m (Maybe (SrcSpan, Type))+++instance HasType (LHsBind Id) where+#if __GLASGOW_HASKELL__ >= 708+    getType _ (L spn FunBind{fun_matches = m}) = return $ Just (spn, typ)+      where in_tys = mg_arg_tys m+            out_typ = mg_res_ty m+            typ = mkFunTys in_tys out_typ+#else+    getType _ (L spn FunBind{fun_matches = MatchGroup _ typ}) = return $ Just (spn, typ)+#endif+    getType _ _ = return Nothing++----------------------------------------------------------------+----------------------------------------------------------------+-- from ghc/InteractiveUI.hs++filterOutChildren :: (a -> TyThing) -> [a] -> [a]+filterOutChildren get_thing xs+    = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]+  where+    implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]++infoThing :: GhcMonad m => (FilePath -> FilePath) -> Expression -> m SDoc+infoThing m (Expression str) = do+    names <- parseName str+#if __GLASGOW_HASKELL__ >= 708+    mb_stuffs <- mapM (getInfo False) names+    let filtered = filterOutChildren (\(t,_f,_i,_fam) -> t) (catMaybes mb_stuffs)+#else+    mb_stuffs <- mapM getInfo names+    let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)+#endif+    return $ vcat (intersperse (text "") $ map (pprInfo m False) filtered)++#if __GLASGOW_HASKELL__ >= 708+pprInfo :: (FilePath -> FilePath) -> Bool -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc+pprInfo m _ (thing, fixity, insts, famInsts)+    = pprTyThingInContextLoc' thing+   $$ show_fixity fixity+   $$ vcat (map pprInstance' insts)+   $$ vcat (map pprFamInst' famInsts)+#else+pprInfo :: (FilePath -> FilePath) -> PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst]) -> SDoc+pprInfo m pefas (thing, fixity, insts)+    = pprTyThingInContextLoc' pefas thing+   $$ show_fixity fixity+   $$ vcat (map pprInstance' insts)+#endif+  where+    show_fixity fx+      | fx == defaultFixity = Outputable.empty+      | otherwise           = ppr fx <+> ppr (getName thing)+#if __GLASGOW_HASKELL__ >= 708+    pprTyThingInContextLoc' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext thing')+#if __GLASGOW_HASKELL__ >= 710+    pprFamInst' (FamInst { fi_flavor = DataFamilyInst rep_tc })+      = pprTyThingInContextLoc (ATyCon rep_tc)++    pprFamInst' (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom+                        , fi_tys = lhs_tys, fi_rhs = rhs })+      = showWithLoc (pprDefinedAt' (getName axiom)) $+        hang (ptext (sLit "type instance") <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys)+           2 (equals <+> ppr rhs)+#else+    pprFamInst' ispec = showWithLoc (pprDefinedAt' (getName ispec)) (pprFamInstHdr ispec)+#endif+#else+    pprTyThingInContextLoc' pefas' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext pefas' thing')+#endif+    showWithLoc loc doc+        = hang doc 2 (char '\t' <> comment <+> loc)+        -- The tab tries to make them line up a bit+      where+        comment = ptext (sLit "--")+    pprInstance' ispec = hang (pprInstanceHdr ispec)+        2 (ptext (sLit "--") <+> pprDefinedAt' (getName ispec))+    pprDefinedAt' thing' = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')+    pprNameDefnLoc' name+      = case Name.nameSrcLoc name of+           RealSrcLoc s -> ptext (sLit "at") <+> ppr (subst s)+           UnhelpfulLoc s+             | Name.isInternalName name || Name.isSystemName name+             -> ptext (sLit "at") <+> ftext s+             | otherwise+             -> ptext (sLit "in") <+> quotes (ppr (nameModule name))+      where subst s = mkRealSrcLoc (realFP s) (srcLocLine s) (srcLocCol s)+            realFP = mkFastString . m . unpackFS . srcLocFile++----------------------------------------------------------------+----------------------------------------------------------------++errorMsgSpan :: ErrMsg -> SrcSpan+#if __GLASGOW_HASKELL__ >= 708+errorMsgSpan = errMsgSpan+#else+errorMsgSpan = head . errMsgSpans+#endif++setErrorMsgSpan :: ErrMsg -> SrcSpan -> ErrMsg+#if __GLASGOW_HASKELL__ >= 708+setErrorMsgSpan err s = err { errMsgSpan = s }+#else+setErrorMsgSpan err s = err { errMsgSpans = [s] }+#endif++typeForUser :: Type -> SDoc+#if __GLASGOW_HASKELL__ >= 708+typeForUser = pprTypeForUser+#else+typeForUser = pprTypeForUser False+#endif++nameForUser :: Name -> SDoc+nameForUser = pprOccName . getOccName++occNameForUser :: OccName -> SDoc+occNameForUser = pprOccName++deSugar :: TypecheckedModule -> LHsExpr Id -> HscEnv+         -> IO (Maybe CoreExpr)+#if __GLASGOW_HASKELL__ >= 708+deSugar _   e hs_env = snd <$> deSugarExpr hs_env e+#else+deSugar tcm e hs_env = snd <$> deSugarExpr hs_env modu rn_env ty_env e+  where+    modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm+    tcgEnv = fst $ tm_internals_ tcm+    rn_env = tcg_rdr_env tcgEnv+    ty_env = tcg_type_env tcgEnv+#endif++----------------------------------------------------------------+----------------------------------------------------------------++data GapThing = GtA Type+              | GtT TyCon+              | GtN+#if __GLASGOW_HASKELL__ >= 800+              | GtPatSyn PatSyn+#endif++fromTyThing :: TyThing -> GapThing+fromTyThing (AnId i)                   = GtA $ varType i+#if __GLASGOW_HASKELL__ >= 708+fromTyThing (AConLike (RealDataCon d)) = GtA $ dataConUserType d+#if __GLASGOW_HASKELL__ >= 800+fromTyThing (AConLike (PatSynCon p))   = GtPatSyn p+#else+fromTyThing (AConLike (PatSynCon p))   = GtA $ patSynType p+#endif+#else+fromTyThing (ADataCon d)               = GtA $ dataConUserType d+#endif+fromTyThing (ATyCon t)                 = GtT t+fromTyThing _                          = GtN++----------------------------------------------------------------+----------------------------------------------------------------++#if __GLASGOW_HASKELL__ >= 704+type WarnFlags = I.IntSet+emptyWarnFlags :: WarnFlags+emptyWarnFlags = I.empty+#else+type WarnFlags = [WarningFlag]+emptyWarnFlags :: WarnFlags+emptyWarnFlags = []+#endif++----------------------------------------------------------------+----------------------------------------------------------------++#if __GLASGOW_HASKELL__ >= 708+type GLMatch = LMatch RdrName (LHsExpr RdrName)+type GLMatchI = LMatch Id (LHsExpr Id)+#else+type GLMatch = LMatch RdrName+type GLMatchI = LMatch Id+#endif++getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan)+#if __GLASGOW_HASKELL__ >= 800+-- Instance declarations of sort 'instance F (G a)'+getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = HsIB _ (L _ (HsForAllTy _ (L _ (HsAppTy (L _ (HsTyVar (L _ className))) _))))}))] = Just (className, loc)+-- Instance declarations of sort 'instance F G' (no variables)+getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = HsIB _ (L _ (HsAppTy (L _ (HsTyVar (L _ className))) _))}))] = Just (className, loc)+#elif __GLASGOW_HASKELL__ >= 710+-- Instance declarations of sort 'instance F (G a)'+getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsForAllTy _ _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _))))}))] = Just (className, loc)+-- Instance declarations of sort 'instance F G' (no variables)+getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsAppTy (L _ (HsTyVar className)) _))}))] = Just (className, loc)+#elif __GLASGOW_HASKELL__ >= 708+-- Instance declarations of sort 'instance F (G a)'+getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _))))}))] = Just (className, loc)+-- Instance declarations of sort 'instance F G' (no variables)+getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsAppTy (L _ (HsTyVar className)) _))}))] = Just (className, loc)+#elif __GLASGOW_HASKELL__ >= 706+getClass [L loc (ClsInstD (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _)))) _ _ _)] = Just (className, loc)+getClass[L loc (ClsInstD (L _ (HsAppTy (L _ (HsTyVar className)) _)) _ _ _)] = Just (className, loc)+#else+getClass [L loc (InstDecl (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _)))) _ _ _)] = Just (className, loc)+getClass [L loc (InstDecl (L _ (HsAppTy (L _ (HsTyVar className)) _)) _ _ _)] = Just (className, loc)+#endif+getClass _ = Nothing++#if __GLASGOW_HASKELL__ < 706+occName :: RdrName -> OccName+occName = rdrNameOcc+#endif++----------------------------------------------------------------++#if __GLASGOW_HASKELL__ < 710+-- Copied from ghc/InteractiveUI.hs+allExposedPackageConfigs :: DynFlags -> [PackageConfig]+allExposedPackageConfigs df = filter exposed $ eltsUFM $ pkgIdMap $ pkgState df++allExposedModules :: DynFlags -> [ModuleName]+allExposedModules df = concat $ map exposedModules $ allExposedPackageConfigs df++listVisibleModuleNames :: DynFlags -> [ModuleName]+listVisibleModuleNames = allExposedModules+#endif++lookupModulePackageInAllPackages ::+    DynFlags -> ModuleName -> [String]+lookupModulePackageInAllPackages df mn =+#if __GLASGOW_HASKELL__ >= 710+    unpackSPId . sourcePackageId . snd <$> lookupModuleInAllPackages df mn+ where+   unpackSPId (SourcePackageId fs) = unpackFS fs+#else+    unpackPId . sourcePackageId . fst <$> lookupModuleInAllPackages df mn+ where+   unpackPId pid = packageIdString $ mkPackageId pid+--       n ++ "-" ++ showVersion v+#endif++listVisibleModules :: DynFlags -> [GHC.Module]+listVisibleModules df = let+#if __GLASGOW_HASKELL__ >= 710+    modNames = listVisibleModuleNames df+    mods = [ m | mn <- modNames, (m, _) <- lookupModuleInAllPackages df mn ]+#else+    pkgCfgs = allExposedPackageConfigs df+    mods = [ mkModule pid modname | p <- pkgCfgs+           , let pid = packageConfigId p+           , modname <- exposedModules p ]+#endif+    in mods++isSynTyCon :: TyCon -> Bool+#if __GLASGOW_HASKELL__ >= 710+isSynTyCon = GHC.isTypeSynonymTyCon+#else+isSynTyCon = GHC.isSynTyCon+#endif+++parseModuleHeader+    :: String         -- ^ Haskell module source text (full Unicode is supported)+    -> DynFlags+    -> FilePath       -- ^ the filename (for source locations)+    -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName))+parseModuleHeader str dflags filename =+   let+       loc  = mkRealSrcLoc (mkFastString filename) 1 1+       buf  = stringToStringBuffer str+   in+   case L.unP Parser.parseHeader (mkPState dflags buf loc) of++     PFailed sp err   ->+#if __GLASGOW_HASKELL__ >= 706+         Left (unitBag (mkPlainErrMsg dflags sp err))+#else+         Left (unitBag (mkPlainErrMsg sp err))+#endif++     POk pst rdr_module ->+         let (warns,_) = getMessages pst in+         Right (warns, rdr_module)++mkErrStyle' :: DynFlags -> PrintUnqualified -> PprStyle+#if __GLASGOW_HASKELL__ >= 706+mkErrStyle' = Outputable.mkErrStyle+#else+mkErrStyle' _ = Outputable.mkErrStyle+#endif++#if __GLASGOW_HASKELL__ < 706+instance NFData ByteString where+  rnf Empty       = ()+  rnf (Chunk _ b) = rnf b+#endif++-- | Like 'everything', but avoid known potholes, based on the 'Stage' that+--   generated the Ast.+everythingStagedWithContext :: Stage -> s -> (r -> r -> r) -> r -> GenericQ (s -> (r, s)) -> GenericQ r+everythingStagedWithContext stage s0 f z q x+  | (const False+#if __GLASGOW_HASKELL__ <= 708+      `extQ` postTcType+#endif+      `extQ` fixity `extQ` nameSet) x = z+  | otherwise = foldl f r (gmapQ (everythingStagedWithContext stage s' f z q) x)+  where nameSet    = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool+#if __GLASGOW_HASKELL__ <= 708+        postTcType = const (stage<TypeChecker)                 :: PostTcType -> Bool+#endif+        fixity     = const (stage<Renamer)                     :: GHC.Fixity -> Bool+        (r, s') = q x s0++withCleanupSession :: GhcMonad m => m a -> m a+#if __GLASGOW_HASKELL__ >= 800+#if MIN_VERSION_GLASGOW_HASKELL(8,0,1,20161117)+withCleanupSession = GHC.withCleanupSession+#else+withCleanupSession ghc = ghc `gfinally` cleanup+  where+   cleanup = do+      hsc_env <- getSession+      let dflags = hsc_dflags hsc_env+      liftIO $ do+          cleanTempFiles dflags+          cleanTempDirs dflags+          stopIServ hsc_env+#endif+#else+withCleanupSession action = do+  df <- getSessionDynFlags+  GHC.defaultCleanupHandler df action+#endif
+ core/GhcMod/GhcPkg.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE BangPatterns, ScopedTypeVariables, TupleSections #-}+module GhcMod.GhcPkg (+    ghcPkgDbOpt+  , ghcPkgDbStackOpts+  , ghcDbStackOpts+  , ghcDbOpt+  , getPackageDbStack+  , getPackageCachePaths+  , getGhcPkgProgram+  ) where++import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt)+import Control.Applicative+import Data.List.Split (splitOn)+import Data.Maybe+import Exception (handleIO)+import System.Directory (doesDirectoryExist, getAppUserDataDirectory)+import System.FilePath ((</>))+import Prelude++import GhcMod.Types+import GhcMod.Monad.Types+import GhcMod.CabalHelper+import GhcMod.PathsAndFiles+import GhcMod.CustomPackageDb+import GhcMod.Stack++ghcVersion :: Int+ghcVersion = read cProjectVersionInt++----------------------------------------------------------------++-- | Get options needed to add a list of package dbs to ghc-pkg's db stack+ghcPkgDbStackOpts :: [GhcPkgDb] -- ^ Package db stack+                  -> [String]+ghcPkgDbStackOpts dbs = ghcPkgDbOpt `concatMap` dbs++-- | Get options needed to add a list of package dbs to ghc's db stack+ghcDbStackOpts :: [GhcPkgDb] -- ^ Package db stack+               -> [String]+ghcDbStackOpts dbs = ghcDbOpt `concatMap` dbs++----------------------------------------------------------------++ghcPkgDbOpt :: GhcPkgDb -> [String]+ghcPkgDbOpt GlobalDb = ["--global"]+ghcPkgDbOpt UserDb   = ["--user"]+ghcPkgDbOpt (PackageDb pkgDb)+  | ghcVersion < 706 = ["--no-user-package-conf", "--package-conf=" ++ pkgDb]+  | otherwise        = ["--no-user-package-db",   "--package-db="   ++ pkgDb]++ghcDbOpt :: GhcPkgDb -> [String]+ghcDbOpt GlobalDb+  | ghcVersion < 706 = ["-global-package-conf"]+  | otherwise        = ["-global-package-db"]+ghcDbOpt UserDb+  | ghcVersion < 706 = ["-user-package-conf"]+  | otherwise        = ["-user-package-db"]+ghcDbOpt (PackageDb pkgDb)+  | ghcVersion < 706 = ["-no-user-package-conf", "-package-conf", pkgDb]+  | otherwise        = ["-no-user-package-db",   "-package-db",   pkgDb]++----------------------------------------------------------------++getGhcPkgProgram :: IOish m => GhcModT m FilePath+getGhcPkgProgram = do+  crdl <- cradle+  progs <- optPrograms <$> options+  case cradleProject crdl of+    (StackProject senv) -> do+        Just ghcPkg <- getStackGhcPkgPath senv+        return ghcPkg+    _ ->+        return $ ghcPkgProgram progs++getPackageDbStack :: IOish m => GhcModT m [GhcPkgDb]+getPackageDbStack = do+  crdl <- cradle+  mCusPkgStack <- getCustomPkgDbStack+  stack <- case cradleProject crdl of+    PlainProject ->+        return [GlobalDb, UserDb]+    SandboxProject -> do+        Just db <- liftIO $ getSandboxDb crdl+        return $ [GlobalDb, db]+    CabalProject ->+        getCabalPackageDbStack+    (StackProject StackEnv {..}) ->+        return $ [GlobalDb, PackageDb seSnapshotPkgDb, PackageDb seLocalPkgDb]+  return $ fromMaybe stack mCusPkgStack++getPackageCachePaths :: IOish m => FilePath -> GhcModT m [FilePath]+getPackageCachePaths sysPkgCfg = do+  pkgDbStack <- getPackageDbStack+  catMaybes <$> (liftIO . resolvePackageConfig sysPkgCfg) `mapM` pkgDbStack++-- TODO: use PkgConfRef+--- Copied from ghc module `Packages' unfortunately it's not exported :/+resolvePackageConfig :: FilePath -> GhcPkgDb -> IO (Maybe FilePath)+resolvePackageConfig sysPkgCfg GlobalDb = return $ Just sysPkgCfg+resolvePackageConfig _ UserDb = handleIO (\_ -> return Nothing) $ do+  appdir <- getAppUserDataDirectory "ghc"+  let dir = appdir </> (target_arch ++ '-':target_os ++ '-':cProjectVersion)+      pkgconf = dir </> "package.conf.d"+  exist <- doesDirectoryExist pkgconf+  return $ if exist then Just pkgconf else Nothing+ where+    [target_arch,_,target_os] = splitOn "-" cTargetPlatformString+resolvePackageConfig _ (PackageDb name) = return $ Just name
+ core/GhcMod/HomeModuleGraph.hs view
@@ -0,0 +1,271 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE ScopedTypeVariables, RecordWildCards #-}+module GhcMod.HomeModuleGraph (+   GmModuleGraph(..)+ , ModulePath(..)+ , mkFileMap+ , mkModuleMap+ , mkMainModulePath+ , findModulePath+ , findModulePathSet+ , fileModuleName+ , canonicalizeModulePath+ , homeModuleGraph+ , updateHomeModuleGraph+ , canonicalizeModuleGraph+ , reachable+ , moduleGraphToDot+ ) where++import DriverPipeline+import DynFlags+import ErrUtils+import Exception+import Finder+import GHC+import HscTypes+import Pretty++import Control.Arrow ((&&&))+import Control.Applicative+import Control.Monad+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)+import Control.Monad.State.Strict (execStateT)+import Control.Monad.State.Class+import Data.Maybe+import Data.Monoid as Monoid+import Data.Map  (Map)+import qualified Data.Map  as Map+import Data.Set (Set)+import qualified Data.Set as Set+import System.FilePath+import System.Directory+import System.IO+import Prelude++import GhcMod.Logging+import GhcMod.Logger+import GhcMod.Monad.Types+import GhcMod.Types+import GhcMod.Utils (withMappedFile)+import GhcMod.Gap (parseModuleHeader)++-- | Turn module graph into a graphviz dot file+--+-- @dot -Tpng -o modules.png modules.dot@+moduleGraphToDot :: GmModuleGraph -> String+moduleGraphToDot GmModuleGraph { gmgGraph } =+    "digraph {\n" ++ concatMap edges (Map.toList graph) ++ "}\n"+ where+   graph = Map.map (Set.mapMonotonic mpPath)+         $ Map.mapKeysMonotonic mpPath gmgGraph+   edges :: (FilePath, (Set FilePath)) -> String+   edges (f, sf) =+       concatMap (\f' -> "    \""++ f ++"\" -> \""++ f' ++"\"\n") (Set.toList sf)++data S = S {+      sErrors   :: [(ModulePath, ErrorMessages)],+      sWarnings :: [(ModulePath, WarningMessages)],+      sGraph    :: GmModuleGraph+}++defaultS :: S+defaultS = S [] [] mempty++putErr :: MonadState S m+       => (ModulePath, ErrorMessages) -> m ()+putErr e = do+  s <- get+  put s { sErrors = e:sErrors s}++putWarn :: MonadState S m+       => (ModulePath, ErrorMessages) -> m ()+putWarn w = do+  s <- get+  put s { sWarnings = w:sWarnings s}++gmgLookupMP :: MonadState S m => ModulePath -> m (Maybe (Set ModulePath))+gmgLookupMP k = (Map.lookup k . gmgGraph . sGraph) `liftM` get++graphUnion :: MonadState S m => GmModuleGraph -> m ()+graphUnion gmg = do+  s <- get+  put s { sGraph = sGraph s `mappend` gmg }++reachable :: Set ModulePath -> GmModuleGraph -> Set ModulePath+reachable smp0 GmModuleGraph {..} = go smp0+ where+   go smp = let+       δsmp = Set.unions $+                collapseMaybeSet . flip Map.lookup gmgGraph <$> Set.toList smp+       smp' = smp `Set.union` δsmp+    in if smp == smp' then smp' else go smp'++pruneUnreachable :: Set ModulePath -> GmModuleGraph -> GmModuleGraph+pruneUnreachable smp0 gmg@GmModuleGraph {..} = let+    r = reachable smp0 gmg+  in+    GmModuleGraph {+      gmgGraph = Map.filterWithKey (\k _ -> k `Set.member` r) gmgGraph+    }++collapseMaybeSet :: Maybe (Set a) -> Set a+collapseMaybeSet = maybe Set.empty id++homeModuleGraph :: (IOish m, Gm m)+    => HscEnv -> Set ModulePath -> m GmModuleGraph+homeModuleGraph env smp = updateHomeModuleGraph env mempty smp smp++mkMainModulePath :: FilePath -> ModulePath+mkMainModulePath = ModulePath (mkModuleName "Main")++findModulePath :: HscEnv -> ModuleName -> IO (Maybe ModulePath)+findModulePath env mn = do+    fmap (ModulePath mn) <$> find env mn++findModulePathSet :: HscEnv -> [ModuleName] -> IO (Set ModulePath)+findModulePathSet env mns = do+    Set.fromList . catMaybes <$> findModulePath env `mapM` mns++find :: MonadIO m => HscEnv -> ModuleName -> m (Maybe FilePath)+find env mn = liftIO $ do+  res <- findHomeModule env mn+  case res of+   -- TODO: handle SOURCE imports (hs-boot stuff): addBootSuffixLocn loc+    Found loc@ModLocation { ml_hs_file = Just _ } _mod ->+        return $ normalise <$> ml_hs_file loc+    _ -> return Nothing+++canonicalizeModulePath :: ModulePath -> IO ModulePath+canonicalizeModulePath (ModulePath mn fp) = ModulePath mn <$> canonicalizePath fp++canonicalizeModuleGraph :: MonadIO m => GmModuleGraph -> m GmModuleGraph+canonicalizeModuleGraph GmModuleGraph {..} = liftIO $ do+    GmModuleGraph . Map.fromList <$> mapM fmg (Map.toList gmgGraph)+ where+   fmg (mp, smp) = liftM2 (,) (canonicalizeModulePath mp) (Set.fromList <$> mapM canonicalizeModulePath (Set.toList smp))+++updateHomeModuleGraph :: (IOish m, Gm m)+                      => HscEnv+                      -> GmModuleGraph+                      -> Set ModulePath -- ^ Initial set of modules+                      -> Set ModulePath -- ^ Updated set of modules+                      -> m GmModuleGraph+updateHomeModuleGraph env GmModuleGraph {..} smp sump = do+    -- TODO: It would be good if we could retain information about modules that+    -- stop to compile after we've already successfully parsed them at some+    -- point. Figure out a way to delete the modules about to be updated only+    -- after we're sure they won't fail to parse .. or something. Should probably+    -- push this whole prune logic deep into updateHomeModuleGraph'+   (pruneUnreachable smp . sGraph) `liftM` runS (updateHomeModuleGraph' env sump)+ where+   runS = flip execStateT defaultS { sGraph = graph' }+   graph' = GmModuleGraph {+       gmgGraph = Set.foldr Map.delete gmgGraph sump+    }++mkFileMap :: Set ModulePath -> Map FilePath ModulePath+mkFileMap smp = Map.fromList $ map (mpPath &&& id) $ Set.toList smp++mkModuleMap :: Set ModulePath -> Map ModuleName ModulePath+mkModuleMap smp = Map.fromList $ map (mpModule &&& id) $ Set.toList smp++updateHomeModuleGraph'+    :: forall m. (MonadState S m, IOish m, Gm m)+    => HscEnv+    -> Set ModulePath     -- ^ Initial set of modules+    -> m ()+updateHomeModuleGraph' env smp0 = do+    go `mapM_` Set.toList smp0+ where+   go :: ModulePath -> m ()+   go mp = do+     msmp <- gmgLookupMP mp+     case msmp of+       Just _ -> return ()+       Nothing -> do+           smp <- collapseMaybeSet `liftM` step mp++           graphUnion GmModuleGraph {+               gmgGraph = Map.singleton mp smp+            }++           mapM_ go (Set.toList smp)++   step :: ModulePath -> m (Maybe (Set ModulePath))+   step mp = runMaybeT $ do+       (dflags, ppsrc_fn) <- MaybeT preprocess'+       src <- liftIO $ readFile ppsrc_fn+       imports mp src dflags+    where+      preprocess' :: m (Maybe (DynFlags, FilePath))+      preprocess' = do+        let fn = mpPath mp+        ep <- preprocessFile env fn+        case ep of+          Right (_, x) -> return $ Just x+          Left errs -> do+            -- TODO: Remember these and present them as proper errors if this is+            -- the file the user is looking at.+            gmLog GmWarning ("preprocess " ++ show fn) $ Pretty.empty $+$ (vcat $ map text errs)+            return Nothing+++   imports :: ModulePath -> String -> DynFlags -> MaybeT m (Set ModulePath)+   imports mp@ModulePath {..} src dflags =+       case parseModuleHeader src dflags mpPath of+         Left err -> do+           putErr (mp, err)+           mzero++         Right (ws, lmdl) -> do+           putWarn (mp, ws)+           let HsModule {..} = unLoc lmdl+               mns = map (unLoc . ideclName)+                   $ filter (isNothing . ideclPkgQual)+                   $ map unLoc hsmodImports+           -- TODO: handle package qualifier "this"+           liftIO $ Set.fromList . catMaybes <$> mapM (findModulePath env) mns++preprocessFile :: (IOish m, GmEnv m, GmState m) =>+  HscEnv -> FilePath -> m (Either [String] ([String], (DynFlags, FilePath)))+preprocessFile env file =+  withLogger' env $ \setDf -> do+    withMappedFile file $ \fn -> do+      let env' = env { hsc_dflags = setDf (hsc_dflags env) }+      liftIO $ preprocess env' (fn, Nothing)++fileModuleName :: (IOish m, GmEnv m, GmState m) =>+  HscEnv -> FilePath -> m (Either [String] (Maybe ModuleName))+fileModuleName env fn = do+    let handler = liftIO . handle (\(_ :: SomeException) -> return $ Right Nothing)+    ep <- preprocessFile env fn+    case ep of+      Left errs -> do+        return $ Left errs+      Right (_warns, (dflags, procdFile)) -> leftM (errBagToStrList env) =<< handler (do+        src <- readFile procdFile+        case parseModuleHeader src dflags procdFile of+          Left errs -> return $ Left errs+          Right (_, lmdl) -> do+            let HsModule {..} = unLoc lmdl+            return $ Right $ unLoc <$> hsmodName)+  where+    leftM f = either (return . Left <=< f) (return . Right)
+ core/GhcMod/LightGhc.hs view
@@ -0,0 +1,60 @@+module GhcMod.LightGhc where++import Control.Monad+import Control.Monad.Reader (runReaderT)+import Data.IORef++import GHC+import GHC.Paths (libdir)+import StaticFlags+import SysTools+import DynFlags+import HscMain+import HscTypes++import GhcMod.Types+import GhcMod.Monad.Types+import GhcMod.DynFlags+import qualified GhcMod.Gap as Gap++-- We have to be more careful about tearing down 'HscEnv's since GHC 8 added an+-- out of process GHCI server which has to be shutdown.+newLightEnv :: IOish m => (DynFlags -> LightGhc DynFlags) -> m HscEnv+newLightEnv mdf = do+  df <- liftIO $ do+     initStaticOpts+     settings <- initSysTools (Just libdir)+     initDynFlags $ defaultDynFlags settings++  hsc_env <- liftIO $ newHscEnv df+  df' <- runLightGhc hsc_env $ mdf df+  return $ hsc_env {+      hsc_dflags = df',+      hsc_IC = (hsc_IC hsc_env) { ic_dflags = df' }+    }++teardownLightEnv :: MonadIO m => HscEnv -> m ()+teardownLightEnv env = runLightGhc env $ do+  Gap.withCleanupSession $ return ()++withLightHscEnv'+    :: IOish m => (DynFlags -> LightGhc DynFlags) -> (HscEnv -> m a) -> m a+withLightHscEnv' mdf action = gbracket (newLightEnv mdf) teardownLightEnv action++withLightHscEnv :: IOish m => [GHCOption] -> (HscEnv -> m a) -> m a+withLightHscEnv opts = withLightHscEnv' (f <=< liftIO . newHscEnv)+ where+   f env = runLightGhc env $ do+         -- HomeModuleGraph and probably all other clients get into all sorts of+         -- trouble if the package state isn't initialized here+         _ <- setSessionDynFlags =<< addCmdOpts opts =<< getSessionDynFlags+         getSessionDynFlags++runLightGhc :: MonadIO m => HscEnv -> LightGhc a -> m a+runLightGhc env action = liftIO $ do+  renv <- newIORef env+  flip runReaderT renv $ unLightGhc action++runLightGhc' :: MonadIO m => IORef HscEnv -> LightGhc a -> m a+runLightGhc' renv action = liftIO $ do+  flip runReaderT renv $ unLightGhc action
+ core/GhcMod/Logger.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE CPP, RankNTypes #-}++module GhcMod.Logger (+    withLogger+  , withLogger'+  , checkErrorPrefix+  , errsToStr+  , errBagToStrList+  ) where++import Control.Arrow+import Control.Applicative+import Data.Ord+import Data.List+import Data.Maybe+import Data.Function+import Control.Monad.Reader (Reader, ask, runReader)+import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)+import System.FilePath (normalise)++import ErrUtils+import GHC+import HscTypes+import Outputable+import qualified GHC as G+import Bag+import SrcLoc+import FastString++import GhcMod.Convert+import GhcMod.Doc (showPage)+import GhcMod.DynFlags (withDynFlags)+import GhcMod.Monad.Types+import GhcMod.Error+import GhcMod.Pretty+import GhcMod.Utils (mkRevRedirMapFunc)+import qualified GhcMod.Gap as Gap+import Prelude++type Builder = [String] -> [String]++data Log = Log [String] Builder++newtype LogRef = LogRef (IORef Log)++data GmPprEnv = GmPprEnv { gpeDynFlags :: DynFlags+                         , gpeMapFile :: FilePath -> FilePath+                         }++type GmPprEnvM a = Reader GmPprEnv a++emptyLog :: Log+emptyLog = Log [] id++newLogRef :: IO LogRef+newLogRef = LogRef <$> newIORef emptyLog++readAndClearLogRef :: LogRef -> IO [String]+readAndClearLogRef (LogRef ref) = do+    Log _ b <- readIORef ref+    writeIORef ref emptyLog+    return $ b []++appendLogRef :: (FilePath -> FilePath) -> DynFlags -> LogRef -> Gap.GmLogAction+appendLogRef map_file df (LogRef ref) _reason _df sev src st msg = do+    modifyIORef ref update+  where+    -- TODO: get rid of ppMsg and just do more or less what ghc's+    -- defaultLogAction does+    l = ppMsg map_file df st src sev msg++    update lg@(Log ls b)+      | l `elem` ls = lg+      | otherwise   = Log (l:ls) (b . (l:))++----------------------------------------------------------------++-- | Logged messages are returned as 'String'.+--   Right is success and Left is failure.+withLogger :: (GmGhc m, GmEnv m, GmOut m, GmState m)+           => (DynFlags -> DynFlags)+           -> m a+           -> m (Either String (String, a))+withLogger f action = do+  env <- G.getSession+  oopts <- outputOpts+  let conv = convert oopts+  eres <- withLogger' env $ \setDf ->+      withDynFlags (f . setDf) action+  return $ either (Left . conv) (Right . first conv) eres++withLogger' :: (IOish m, GmState m, GmEnv m)+    => HscEnv -> ((DynFlags -> DynFlags) -> m a) -> m (Either [String] ([String], a))+withLogger' env action = do+    logref <- liftIO $ newLogRef++    rfm <- mkRevRedirMapFunc++    let setLogger df = Gap.setLogAction df $ appendLogRef rfm df logref+        handlers = [+            GHandler $ \ex -> return $ Left $ runReader (sourceError ex) gpe,+            GHandler $ \ex -> return $ Left [renderGm $ ghcExceptionDoc ex]+          ]+        gpe = GmPprEnv {+                gpeDynFlags = hsc_dflags env+              , gpeMapFile = rfm+        }++    a <- gcatches (Right <$> action setLogger) handlers+    ls <- liftIO $ readAndClearLogRef logref++    return ((,) ls <$> a)++errBagToStrList :: (IOish m, GmState m, GmEnv m) => HscEnv -> Bag ErrMsg -> m [String]+errBagToStrList env errs = do+   rfm <- mkRevRedirMapFunc+   return $ runReader+    (errsToStr (sortMsgBag errs))+    GmPprEnv{ gpeDynFlags = hsc_dflags env, gpeMapFile = rfm }++----------------------------------------------------------------++-- | Converting 'SourceError' to 'String'.+sourceError :: SourceError -> GmPprEnvM [String]+sourceError = errsToStr . sortMsgBag . srcErrorMessages++errsToStr :: [ErrMsg] -> GmPprEnvM [String]+errsToStr = mapM ppErrMsg++sortMsgBag :: Bag ErrMsg -> [ErrMsg]+sortMsgBag bag = sortBy (compare `on` Gap.errorMsgSpan) $ bagToList bag++----------------------------------------------------------------++ppErrMsg :: ErrMsg -> GmPprEnvM String+ppErrMsg err = do+    GmPprEnv {..} <- ask+    let unqual = errMsgContext err+        st = Gap.mkErrStyle' gpeDynFlags unqual+        err' = Gap.setErrorMsgSpan err $ mapSrcSpanFile gpeMapFile (Gap.errorMsgSpan err)+    return $ showPage gpeDynFlags st $ pprLocErrMsg err'++mapSrcSpanFile :: (FilePath -> FilePath) -> SrcSpan -> SrcSpan+mapSrcSpanFile map_file (RealSrcSpan s)   =+    RealSrcSpan $ mapRealSrcSpanFile map_file s+mapSrcSpanFile _ (UnhelpfulSpan s) =+    UnhelpfulSpan s++mapRealSrcSpanFile :: (FilePath -> FilePath) -> RealSrcSpan -> RealSrcSpan+mapRealSrcSpanFile map_file s = let+    start = mapRealSrcLocFile map_file $ realSrcSpanStart s+    end   = mapRealSrcLocFile map_file $ realSrcSpanEnd s+  in+    mkRealSrcSpan start end++mapRealSrcLocFile :: (FilePath -> FilePath) -> RealSrcLoc -> RealSrcLoc+mapRealSrcLocFile map_file l = let+    file = mkFastString $ map_file $ unpackFS $ srcLocFile l+    line = srcLocLine l+    col  = srcLocCol l+  in+    mkRealSrcLoc file line col++ppMsg :: (FilePath -> FilePath) -> DynFlags -> PprStyle -> SrcSpan -> Severity -> SDoc -> String+ppMsg map_file df st spn sev msg = let+    cts = showPage df st msg+  in+    ppMsgPrefix map_file df spn sev cts ++ cts++ppMsgPrefix :: (FilePath -> FilePath) -> DynFlags -> SrcSpan -> Severity -> String -> String+ppMsgPrefix map_file df spn sev cts =+  let+      defaultPrefix = if Gap.isDumpSplices df then "" else checkErrorPrefix+  in+    fromMaybe defaultPrefix $ do+      (line,col,_,_) <- Gap.getSrcSpan spn+      file <- map_file <$> normalise <$> Gap.getSrcFile spn+      return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" +++        if or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes)+          then ""+          else Gap.showSeverityCaption sev++checkErrorPrefix :: String+checkErrorPrefix = "Dummy:0:0:Error:"++warningAsErrorPrefixes :: [String]+warningAsErrorPrefixes = [ "Couldn't match expected type"+                         , "Couldn't match type"+                         , "No instance for"]
+ core/GhcMod/Logging.hs view
@@ -0,0 +1,115 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module GhcMod.Logging (+    module GhcMod.Logging+  , module GhcMod.Pretty+  , GmLogLevel(..)+  , module Data.Monoid+  , module Pretty+  ) where++import Control.Applicative hiding (empty)+import Control.Monad+import Control.Monad.Trans.Class+import Data.List+import Data.Char+import Data.Monoid+import Data.Maybe+import System.IO+import System.FilePath+import Prelude++import Pretty hiding (style, (<>))++import GhcMod.Monad.Types+import GhcMod.Types+import GhcMod.Pretty+import GhcMod.Output++gmSetLogLevel :: GmLog m => GmLogLevel -> m ()+gmSetLogLevel level =+    gmlJournal $ GhcModLog (Just level) (Last Nothing) []++gmGetLogLevel :: forall m. GmLog m => m GmLogLevel+gmGetLogLevel = do+  GhcModLog { gmLogLevel = Just level } <-  gmlHistory+  return level++gmSetDumpLevel :: GmLog m => Bool -> m ()+gmSetDumpLevel level =+    gmlJournal $ GhcModLog Nothing (Last (Just level)) []+++increaseLogLevel :: GmLogLevel -> GmLogLevel+increaseLogLevel l | l == maxBound = l+increaseLogLevel l = succ l++decreaseLogLevel :: GmLogLevel -> GmLogLevel+decreaseLogLevel l | l == minBound = l+decreaseLogLevel l = pred l++-- |+-- >>> Just GmDebug <= Nothing+-- False+-- >>> Just GmException <= Just GmDebug+-- True+-- >>> Just GmDebug <= Just GmException+-- False+gmLog :: (MonadIO m, GmLog m, GmOut m) => GmLogLevel -> String -> Doc -> m ()+gmLog level loc' doc = do+  GhcModLog { gmLogLevel = Just level' } <- gmlHistory++  let loc | loc' == "" = empty+          | otherwise = text loc' <+>: empty+      msgDoc = sep [loc, doc]+      msg = dropWhileEnd isSpace $ renderGm $ gmLogLevelDoc level <+>: msgDoc++  when (level <= level') $ gmErrStrLn msg+  gmLogQuiet level loc' doc++gmLogQuiet :: GmLog m => GmLogLevel -> String -> Doc -> m ()+gmLogQuiet level loc doc =+  gmlJournal (GhcModLog Nothing (Last Nothing) [(level, loc, doc)])++gmAppendLogQuiet :: GmLog m => GhcModLog -> m ()+gmAppendLogQuiet GhcModLog { gmLogMessages } =+    forM_ gmLogMessages $ \(level, loc, doc) -> gmLogQuiet level loc doc++gmVomit :: (MonadIO m, GmLog m, GmOut m, GmEnv m) => String -> Doc -> String -> m ()+gmVomit filename doc content = do+  gmLog GmVomit "" $ doc <+>: text content++  GhcModLog { gmLogVomitDump = Last mdump }+      <- gmlHistory++  dir <- cradleTempDir `liftM` cradle+  when (fromMaybe False mdump) $+       liftIO $ writeFile (dir </> filename) content+++newtype LogDiscardT m a = LogDiscardT { runLogDiscard :: m a }+    deriving (Functor, Applicative, Monad)++instance MonadTrans LogDiscardT where+    lift = LogDiscardT++instance Monad m => GmLog (LogDiscardT m) where+    gmlJournal = const $ return ()+    gmlHistory = return mempty+    gmlClear = return ()
+ core/GhcMod/Monad.hs view
@@ -0,0 +1,148 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP #-}+module GhcMod.Monad (+    runGmOutT+  , runGmOutT'+  , runGhcModT+  , runGhcModT'+  , hoistGhcModT+  , runGmlT+  , runGmlT'+  , runGmlTWith+  , runGmPkgGhc+  , withGhcModEnv+  , withGhcModEnv'+  , module GhcMod.Monad.Types+  ) where++import GhcMod.Types+import GhcMod.Monad.Types+import GhcMod.Error+import GhcMod.Logging+import GhcMod.Cradle+import GhcMod.Target+import GhcMod.Output++import Control.Arrow (first)+import Control.Applicative++import Control.Concurrent++import Control.Monad.Reader (runReaderT)+import Control.Monad.State.Strict (runStateT)+import Control.Monad.Trans.Journal (runJournalT)++import Exception++import System.Directory+import System.IO.Unsafe+import Prelude++withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a+withGhcModEnv dir opts f = withGhcModEnv' withCradle dir opts f+ where+   withCradle dir' =+       gbracket+         (runJournalT $ do+            gmSetLogLevel $ ooptLogLevel $ optOutput opts+            findCradle' (optPrograms opts) dir')+         (liftIO . cleanupCradle . fst)++++cwdLock :: MVar ThreadId+cwdLock = unsafePerformIO $ newEmptyMVar+{-# NOINLINE cwdLock #-}++withGhcModEnv' :: (IOish m, GmOut m) => (FilePath -> ((Cradle, GhcModLog) -> m a) -> m a) -> FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a+withGhcModEnv' withCradle dir opts f =+    withCradle dir $ \(crdl,lg) ->+      withCradleRootDir crdl $+        f (GhcModEnv opts crdl, lg)+ where+   swapCurrentDirectory ndir = do+     odir <- canonicalizePath =<< getCurrentDirectory+     setCurrentDirectory ndir+     return odir++   withCradleRootDir (cradleRootDir -> projdir) a = do+       success <- liftIO $ tryPutMVar cwdLock =<< myThreadId+       if not success+         then error "withGhcModEnv': using ghc-mod from multiple threads is not supported!"+         else gbracket setup teardown (const a)+    where+      setup = liftIO $ swapCurrentDirectory projdir++      teardown odir = liftIO $ do+        setCurrentDirectory odir+        void $ takeMVar cwdLock++runGmOutT :: IOish m => Options -> GmOutT m a -> m a+runGmOutT opts ma = do+    gmo@GhcModOut{..} <- GhcModOut (optOutput opts) <$> liftIO newChan+    let action = runGmOutT' gmo ma+    case ooptLinePrefix $ optOutput opts of+      Nothing -> action+      Just pfxs ->+        gbracket_ (liftIO $ forkIO $ stdoutGateway pfxs gmoChan)+                  (const $ liftIO $ flushStdoutGateway gmoChan)+                  action++runGmOutT' :: GhcModOut -> GmOutT m a -> m a+runGmOutT' gmo ma = flip runReaderT gmo $ unGmOutT ma++-- | Run a @GhcModT m@ computation.+runGhcModT :: IOish m+           => Options+           -> GhcModT m a+           -> m (Either GhcModError a, GhcModLog)+runGhcModT opt action = liftIO (getCurrentDirectory >>= canonicalizePath) >>= \dir' -> do+    runGmOutT opt $+      withGhcModEnv dir' opt $ \(env,lg) ->+        first (fst <$>) <$> runGhcModT' env defaultGhcModState (do+          gmSetLogLevel (ooptLogLevel $ optOutput opt)+          gmAppendLogQuiet lg+          action)++-- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT+-- computation. Note that if the computation that returned @result@ modified the+-- state part of GhcModT this cannot be restored.+hoistGhcModT :: IOish m+             => (Either GhcModError a, GhcModLog)+             -> GhcModT m a+hoistGhcModT (r,l) = do+  gmlJournal l >> case r of+    Left e -> throwError e+    Right a -> return a+++-- | Run a computation inside @GhcModT@ providing the RWST environment and+-- initial state. This is a low level function, use it only if you know what to+-- do with 'GhcModEnv' and 'GhcModState'.+--+-- You should probably look at 'runGhcModT' instead.+runGhcModT' :: IOish m+             => GhcModEnv+             -> GhcModState+             -> GhcModT m a+             -> GmOutT m (Either GhcModError (a, GhcModState), GhcModLog)+runGhcModT' r s a = do+  flip runReaderT r $ runJournalT $ runErrorT $ runStateT (unGmT a) s++gbracket_ :: ExceptionMonad m => m a -> (a -> m b) -> m c -> m c+gbracket_ ma mb mc = gbracket ma mb (const mc)
+ core/GhcMod/Monad/Compat.hs_h view
@@ -0,0 +1,28 @@+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015,2016  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++-- 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
+ core/GhcMod/Monad/Env.hs view
@@ -0,0 +1,68 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015,2016  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}++module GhcMod.Monad.Env where++import GhcMod.Types+import GhcMod.Monad.Newtypes++import Control.Monad+import Control.Monad.Trans.Journal (JournalT)+import Control.Monad.State.Strict (StateT(..))+import Control.Monad.Error (ErrorT(..))+import Control.Monad.Reader.Class+import Control.Monad.Trans.Class (MonadTrans(..))+import Prelude++class Monad m => GmEnv m where+    gmeAsk :: m GhcModEnv+    gmeAsk = gmeReader id++    gmeReader :: (GhcModEnv -> a) -> m a+    gmeReader f = f `liftM` gmeAsk++    gmeLocal :: (GhcModEnv -> GhcModEnv) -> m a -> m a+    {-# MINIMAL (gmeAsk | gmeReader), gmeLocal #-}++instance Monad m => GmEnv (GmT m) where+    gmeAsk = GmT ask+    gmeReader = GmT . reader+    gmeLocal f a = GmT $ local f (unGmT a)++instance GmEnv m => GmEnv (GmOutT m) where+    gmeAsk = lift gmeAsk+    gmeReader = lift . gmeReader+    gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma))++instance GmEnv m => GmEnv (StateT s m) where+    gmeAsk = lift gmeAsk+    gmeReader = lift . gmeReader+    gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma))++instance GmEnv m => GmEnv (JournalT GhcModLog m) where+    gmeAsk = lift gmeAsk+    gmeReader = lift . gmeReader+    gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma))++instance GmEnv m => GmEnv (ErrorT GhcModError m) where+    gmeAsk = lift gmeAsk+    gmeReader = lift . gmeReader+    gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma))++deriving instance (Monad m, GmEnv (GhcModT m)) => GmEnv (GmlT m)
+ core/GhcMod/Monad/Log.hs view
@@ -0,0 +1,71 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015,2016  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}++module GhcMod.Monad.Log where++import GhcMod.Types+import GhcMod.Monad.Newtypes++import Control.Monad+import Control.Monad.Trans.Journal (JournalT)+import Control.Monad.Reader (ReaderT(..))+import Control.Monad.State.Strict (StateT(..))+import Control.Monad.Error (Error, ErrorT(..))+import Control.Monad.Trans.Maybe (MaybeT(..))+import Control.Monad.Journal.Class (MonadJournal(..))+import Control.Monad.Trans.Class (MonadTrans(..))+import Prelude++class Monad m => GmLog m where+    gmlJournal :: GhcModLog -> m ()+    gmlHistory :: m GhcModLog+    gmlClear   :: m ()++instance Monad m => GmLog (JournalT GhcModLog m) where+    gmlJournal = journal+    gmlHistory = history+    gmlClear   = clear++instance Monad m => GmLog (GmT m) where+    gmlJournal = GmT . lift . lift . journal+    gmlHistory = GmT $ lift $ lift history+    gmlClear   = GmT $ lift $ lift clear++instance (Monad m, GmLog m) => GmLog (ReaderT r m) where+    gmlJournal = lift . gmlJournal+    gmlHistory = lift gmlHistory+    gmlClear = lift  gmlClear++instance (Monad m, GmLog m) => GmLog (StateT s m) where+    gmlJournal = lift . gmlJournal+    gmlHistory = lift gmlHistory+    gmlClear = lift gmlClear++instance (Monad m, GmLog m, Error e) => GmLog (ErrorT e m) where+    gmlJournal = lift . gmlJournal+    gmlHistory = lift gmlHistory+    gmlClear = lift gmlClear++instance (Monad m, GmLog m) => GmLog (MaybeT m) where+    gmlJournal = lift . gmlJournal+    gmlHistory = lift gmlHistory+    gmlClear = lift gmlClear++deriving instance GmLog m => GmLog (GmOutT m)+deriving instance (Monad m, GmLog (GhcModT m)) => GmLog (GmlT m)
+ core/GhcMod/Monad/Newtypes.hs view
@@ -0,0 +1,176 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015,2016  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, DeriveFunctor #-}+{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-}+{-# LANGUAGE RankNTypes, FlexibleInstances #-}++module GhcMod.Monad.Newtypes where++#include "Compat.hs_h"++import GhcMod.Types++import GHC++import Control.Applicative+import Control.Monad++import Control.Monad.Reader (ReaderT(..))+import Control.Monad.Error (ErrorT(..), MonadError(..))+import Control.Monad.State.Strict (StateT(..))+import Control.Monad.Trans.Journal (JournalT)+import Control.Monad.Reader.Class+import Control.Monad.State.Class (MonadState(..))+import Control.Monad.Journal.Class (MonadJournal(..))+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.Control+import Control.Monad.Base (MonadBase(..), liftBase)++import Data.IORef+import Prelude++type GhcModT m = GmT (GmOutT m)++newtype GmOutT m a = GmOutT {+      unGmOutT :: ReaderT GhcModOut m a+    } deriving ( Functor+               , Applicative+               , Alternative+               , Monad+               , MonadPlus+               , MonadTrans+               )++newtype GmT m a = GmT {+      unGmT :: StateT GhcModState+                 (ErrorT GhcModError+                   (JournalT GhcModLog+                     (ReaderT GhcModEnv m) ) ) a+    } deriving ( Functor+               , Applicative+               , Alternative+               , Monad+               , MonadPlus+               , MonadError GhcModError+               )++newtype GmlT m a = GmlT { unGmlT :: GhcModT m a }+    deriving ( Functor+             , Applicative+             , Alternative+             , Monad+             , MonadPlus+             , MonadError GhcModError+             )++newtype LightGhc a = LightGhc { unLightGhc :: ReaderT (IORef HscEnv) IO a }+    deriving ( Functor+             , Applicative+             , Monad+             )++-- GmOutT ----------------------------------------+instance (MonadBaseControl IO m) => MonadBase IO (GmOutT m) where+    liftBase = GmOutT . liftBase++instance (MonadBaseControl IO m) => MonadBaseControl IO (GmOutT m) where+    type StM (GmOutT m) a = StM (ReaderT GhcModEnv m) a+    liftBaseWith = defaultLiftBaseWith+    restoreM = defaultRestoreM+    {-# INLINE liftBaseWith #-}+    {-# INLINE restoreM #-}++instance MonadTransControl GmOutT where+    type StT GmOutT a = StT (ReaderT GhcModEnv) a+    liftWith = defaultLiftWith GmOutT unGmOutT+    restoreT = defaultRestoreT GmOutT+++-- GmlT ------------------------------------------+instance (MonadBaseControl IO m) => MonadBase IO (GmlT m) where+    liftBase = GmlT . liftBase++instance (MonadBaseControl IO m) => MonadBaseControl IO (GmlT m) where+    type StM (GmlT m) a = StM (GmT m) a+    liftBaseWith = defaultLiftBaseWith+    restoreM = defaultRestoreM+    {-# INLINE liftBaseWith #-}+    {-# INLINE restoreM #-}++instance MonadTransControl GmlT where+    type StT GmlT a = StT GmT a+    liftWith f = GmlT $+      liftWith $ \runGm ->+        liftWith $ \runEnv ->+          f $ \ma -> runEnv $ runGm $ unGmlT ma+    restoreT = GmlT . restoreT . restoreT++instance MonadTrans GmlT where+    lift = GmlT . lift . lift++-- GmT ------------------------------------------++instance MonadReader r m => MonadReader r (GmT m) where+    local f ma = gmLiftWithInner (\run -> local f (run ma))+    ask = gmLiftInner ask++instance MonadState s m => MonadState s (GmT m) where+    get = GmT $ lift $ lift $ lift get+    put = GmT . lift . lift . lift . put+    state = GmT . lift . lift . lift . state++instance Monad m => MonadJournal GhcModLog (GmT m) where+  journal  w = GmT $ lift $ lift $ (journal w)+  history    = GmT $ lift $ lift $ history+  clear      = GmT $ lift $ lift $ clear++instance (MonadBaseControl IO m) => MonadBase IO (GmT m) where+    liftBase = GmT . liftBase++instance (MonadBaseControl IO m) => MonadBaseControl IO (GmT m) where+    type StM (GmT m) a =+          StM (StateT GhcModState+                (ErrorT GhcModError+                  (JournalT GhcModLog+                    (ReaderT GhcModEnv m) ) ) ) a+    liftBaseWith f = GmT (liftBaseWith $ \runInBase ->+        f $ runInBase . unGmT)+    restoreM = GmT . restoreM+    {-# INLINE liftBaseWith #-}+    {-# INLINE restoreM #-}++instance MonadTransControl GmT where+    type StT GmT a = (Either GhcModError (a, GhcModState), GhcModLog)+    liftWith f = GmT $+      liftWith $ \runS ->+        liftWith $ \runE ->+          liftWith $ \runJ ->+            liftWith $ \runR ->+              f $ \ma -> runR $ runJ $ runE $ runS $ unGmT ma+    restoreT = GmT . restoreT . restoreT . restoreT . restoreT+    {-# INLINE liftWith #-}+    {-# INLINE restoreT #-}++instance MonadTrans GmT where+    lift = GmT . lift . lift . lift . lift++gmLiftInner :: Monad m => m a -> GmT m a+gmLiftInner = GmT . lift . lift . lift . lift++gmLiftWithInner :: (MonadTransControl t, Monad m, Monad (t m))+                => (Run t -> m (StT t a)) -> t m a+gmLiftWithInner f = liftWith f >>= restoreT . return
+ core/GhcMod/Monad/Orphans.hs view
@@ -0,0 +1,83 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015,2016  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP, UndecidableInstances, StandaloneDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}+module GhcMod.Monad.Orphans where++#include "Compat.hs_h"++import GhcMod.Types+import GhcMod.Monad.Newtypes++#if DIFFERENT_MONADIO+import qualified MonadUtils as GHC (MonadIO(..))+#endif+import qualified Control.Monad.IO.Class as MTL++import Control.Monad.Reader (ReaderT(..))+import Control.Monad.State.Strict (StateT(..))+import Control.Monad.Trans.Journal (JournalT)+import Control.Monad.Trans.Maybe (MaybeT(..))+import Control.Monad.Error (Error(..), ErrorT(..))++--------------------------------------------------+-- Miscellaneous instances++#if DIFFERENT_MONADIO+instance MTL.MonadIO m => GHC.MonadIO (ReaderT x m) where+    liftIO = MTL.liftIO+instance MTL.MonadIO m => GHC.MonadIO (StateT x m) where+    liftIO = MTL.liftIO+instance (Error e, MTL.MonadIO m) => GHC.MonadIO (ErrorT e m) where+    liftIO = MTL.liftIO+instance MTL.MonadIO m => GHC.MonadIO (JournalT x m) where+    liftIO = MTL.liftIO+instance MTL.MonadIO m => GHC.MonadIO (MaybeT m) where+    liftIO = MTL.liftIO+deriving instance MTL.MonadIO m => GHC.MonadIO (GmOutT m)+deriving instance MTL.MonadIO m => GHC.MonadIO (GmT m)+deriving instance MTL.MonadIO m => GHC.MonadIO (GmlT m)+deriving instance GHC.MonadIO LightGhc+#endif++deriving instance MTL.MonadIO m => MTL.MonadIO (GmOutT m)+deriving instance MTL.MonadIO m => MTL.MonadIO (GmT m)+deriving instance MTL.MonadIO m => MTL.MonadIO (GmlT m)+deriving instance MTL.MonadIO LightGhc++instance MonadIO IO where+    liftIO = id+instance MonadIO m => MonadIO (ReaderT x m) where+    liftIO = MTL.liftIO+instance MonadIO m => MonadIO (StateT x m) where+    liftIO = MTL.liftIO+instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where+    liftIO = MTL.liftIO+instance MonadIO m => MonadIO (JournalT x m) where+    liftIO = MTL.liftIO+instance MonadIO m => MonadIO (MaybeT m) where+    liftIO = MTL.liftIO+instance MonadIOC m => MonadIO (GmOutT m) where+    liftIO = MTL.liftIO+instance MonadIOC m => MonadIO (GmT m) where+    liftIO = MTL.liftIO+instance MonadIOC m => MonadIO (GmlT m) where+    liftIO = MTL.liftIO+instance MonadIO LightGhc where+    liftIO = MTL.liftIO
+ core/GhcMod/Monad/Out.hs view
@@ -0,0 +1,52 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015,2016  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}++module GhcMod.Monad.Out where++import GhcMod.Types+import GhcMod.Monad.Newtypes++import Control.Monad+import Control.Monad.State.Strict (StateT(..))+import Control.Monad.Trans.Journal (JournalT)+import Control.Monad.Trans.Maybe (MaybeT(..))+import Control.Monad.Reader.Class+import Control.Monad.Trans.Class (MonadTrans(..))+import Prelude++class Monad m => GmOut m where+    gmoAsk :: m GhcModOut++instance Monad m => GmOut (GmOutT m) where+    gmoAsk = GmOutT ask++instance Monad m => GmOut (GmlT m) where+    gmoAsk = GmlT $ lift $ GmOutT ask++instance GmOut m => GmOut (GmT m) where+    gmoAsk = lift gmoAsk++instance GmOut m => GmOut (StateT s m) where+    gmoAsk = lift gmoAsk++instance GmOut m => GmOut (JournalT w m) where+    gmoAsk = lift gmoAsk++instance GmOut m => GmOut (MaybeT m) where+    gmoAsk = lift gmoAsk
+ core/GhcMod/Monad/State.hs view
@@ -0,0 +1,67 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015,2016  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-}+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}++module GhcMod.Monad.State where++import GhcMod.Types+import GhcMod.Monad.Newtypes++import Control.Monad+import Control.Monad.State.Strict (StateT(..))+import Control.Monad.Trans.Maybe (MaybeT(..))+import Control.Monad.State.Class (MonadState(..))+import Control.Monad.Trans.Class (MonadTrans(..))+import Prelude++class Monad m => GmState m where+    gmsGet :: m GhcModState+    gmsGet = gmsState (\s -> (s, s))++    gmsPut :: GhcModState -> m ()+    gmsPut s = gmsState (\_ -> ((), s))++    gmsState :: (GhcModState -> (a, GhcModState)) -> m a+    gmsState f = do+      s <- gmsGet+      let ~(a, s') = f s+      gmsPut s'+      return a+    {-# MINIMAL gmsState | gmsGet, gmsPut #-}++instance GmState m => GmState (StateT s m) where+    gmsGet = lift gmsGet+    gmsPut = lift . gmsPut+    gmsState = lift . gmsState++instance Monad m => GmState (StateT GhcModState m) where+    gmsGet = get+    gmsPut = put+    gmsState = state++instance Monad m => GmState (GmT m) where+    gmsGet = GmT get+    gmsPut = GmT . put+    gmsState = GmT . state++instance GmState m => GmState (MaybeT m) where+    gmsGet = MaybeT $ Just `liftM` gmsGet+    gmsPut = MaybeT . (Just `liftM`) . gmsPut+    gmsState = MaybeT . (Just `liftM`) . gmsState++deriving instance (Monad m, GmState (GhcModT m)) => GmState (GmlT m)
+ core/GhcMod/Monad/Types.hs view
@@ -0,0 +1,239 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-}+{-# LANGUAGE TypeFamilies, UndecidableInstances, BangPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module GhcMod.Monad.Types (+  -- * Monad Types+    GhcModT+  , GmOutT(..)+  , GmT(..)+  , GmlT(..)+  , LightGhc(..)+  , GmGhc+  , IOish+  -- * Environment, state and logging+  , GhcModEnv(..)+  , GhcModState(..)+  , GhcModCaches(..)+  , defaultGhcModState+  , GmGhcSession(..)+  , GmComponent(..)+  -- * Accessing 'GhcModEnv', 'GhcModState' and 'GhcModLog'+  , GmLogLevel(..)+  , GhcModLog(..)+  , GhcModError(..)+  , Gm+  , GmEnv(..)+  , GmState(..)+  , GmLog(..)+  , GmOut(..)+  , cradle+  , options+  , outputOpts+  , withOptions+  , getMMappedFiles+  , setMMappedFiles+  , addMMappedFile+  , delMMappedFile+  , lookupMMappedFile+  , getMMappedFilePaths+  -- * Re-exporting convenient stuff+  , MonadIO+  , liftIO+  , gmlGetSession+  , gmlSetSession+  ) where++#include "Compat.hs_h"++import GhcMod.Types++import GhcMod.Monad.Env+import GhcMod.Monad.State+import GhcMod.Monad.Log+import GhcMod.Monad.Out+import GhcMod.Monad.Newtypes+import GhcMod.Monad.Orphans ()++import Safe++import GHC+import DynFlags+import Exception+import HscTypes++import Control.Applicative+import Control.Monad++import Control.Monad.Reader (ReaderT(..))+import Control.Monad.State.Strict (StateT(..))+import Control.Monad.Trans.Journal (JournalT)+import Control.Monad.Trans.Maybe (MaybeT)++import Control.Monad.Trans.Control++import Control.Monad.Reader.Class++import qualified Data.Map as M+import Data.Maybe+import Data.Monoid+import Data.IORef+import Prelude++type Gm m = (GmEnv m, GmState m, GmLog m, GmOut m)++--------------------------------------------------+-- GHC API instances -----------------------------++-- GHC cannot prove the following instances to be decidable automatically using+-- the FlexibleContexts extension as they violate the second Paterson Condition,+-- namely that: The assertion has fewer constructors and variables (taken+-- together and counting repetitions) than the head. Specifically the+-- @MonadBaseControl IO m@ constraint in 'IOish' is causing this violation.++type GmGhc m = (IOish m, GhcMonad m)++instance (MonadIO m, MonadBaseControl IO m) => GhcMonad (GmlT m) where+    getSession = gmlGetSession+    setSession = gmlSetSession++-- | Get the underlying GHC session+gmlGetSession :: (MonadIO m, MonadBaseControl IO m) => GmlT m HscEnv+gmlGetSession = do+        ref <- gmgsSession . fromJustNote "gmlGetSession" . gmGhcSession <$> gmsGet+        liftIO $ readIORef ref++-- | Set the underlying GHC session+gmlSetSession :: (MonadIO m, MonadBaseControl IO m) => HscEnv -> GmlT m ()+gmlSetSession a = do+        ref <- gmgsSession . fromJustNote "gmlSetSession" . gmGhcSession <$> gmsGet+        liftIO $ flip writeIORef a ref++instance GhcMonad LightGhc where+    getSession = (liftIO . readIORef) =<< LightGhc ask+    setSession a = (liftIO . flip writeIORef a) =<< LightGhc ask++#if __GLASGOW_HASKELL__ >= 706+instance (MonadIO m, MonadBaseControl IO m) => HasDynFlags (GmlT m) where+    getDynFlags = hsc_dflags <$> getSession++instance HasDynFlags LightGhc where+    getDynFlags = hsc_dflags <$> getSession+#endif++instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmOutT m) where+    gcatch act handler = control $ \run ->+        run act `gcatch` (run . handler)++    gmask = liftBaseOp gmask . liftRestore+     where liftRestore f r = f $ liftBaseOp_ r++instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmT m) where+    gcatch act handler = control $ \run ->+        run act `gcatch` (run . handler)++    gmask = liftBaseOp gmask . liftRestore+     where liftRestore f r = f $ liftBaseOp_ r++instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmlT m) where+    gcatch act handler = control $ \run ->+        run act `gcatch` (run . handler)++    gmask = liftBaseOp gmask . liftRestore+     where liftRestore f r = f $ liftBaseOp_ r++instance ExceptionMonad LightGhc where+  gcatch act handl =+      LightGhc $ unLightGhc act `gcatch` \e -> unLightGhc (handl e)+  gmask f =+      LightGhc $ gmask $ \io_restore ->let+          g_restore (LightGhc m) = LightGhc $ io_restore m+      in+        unLightGhc (f g_restore)+++instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (StateT s m) where+    gcatch act handler = control $ \run ->+        run act `gcatch` (run . handler)++    gmask = liftBaseOp gmask . liftRestore+     where liftRestore f r = f $ liftBaseOp_ r++instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (ReaderT s m) where+    gcatch act handler = control $ \run ->+        run act `gcatch` (run . handler)++    gmask = liftBaseOp gmask . liftRestore+     where liftRestore f r = f $ liftBaseOp_ r++instance (Monoid w, MonadIO m, MonadBaseControl IO m) => ExceptionMonad (JournalT w m) where+    gcatch act handler = control $ \run ->+        run act `gcatch` (run . handler)++    gmask = liftBaseOp gmask . liftRestore+     where liftRestore f r = f $ liftBaseOp_ r++instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (MaybeT m) where+    gcatch act handler = control $ \run ->+        run act `gcatch` (run . handler)++    gmask = liftBaseOp gmask . liftRestore+     where liftRestore f r = f $ liftBaseOp_ r+++----------------------------------------------------------------++options :: GmEnv m => m Options+options = gmOptions `liftM` gmeAsk++outputOpts :: GmOut m => m OutputOpts+outputOpts = gmoOptions `liftM` gmoAsk++cradle :: GmEnv m => m Cradle+cradle = gmCradle `liftM` gmeAsk++getMMappedFiles :: GmState m => m FileMappingMap+getMMappedFiles = gmMMappedFiles `liftM` gmsGet++setMMappedFiles :: GmState m => FileMappingMap -> m ()+setMMappedFiles mf = (\s -> gmsPut s { gmMMappedFiles = mf } ) =<< gmsGet++addMMappedFile  :: GmState m => FilePath -> FileMapping -> m ()+addMMappedFile t fm =+  getMMappedFiles >>= setMMappedFiles . M.insert t fm++delMMappedFile  :: GmState m => FilePath -> m ()+delMMappedFile t =+  getMMappedFiles >>= setMMappedFiles . M.delete t++lookupMMappedFile  :: GmState m => FilePath -> m (Maybe FileMapping)+lookupMMappedFile t =+  M.lookup t `liftM` getMMappedFiles++getMMappedFilePaths :: GmState m => m [FilePath]+getMMappedFilePaths = M.keys `liftM` getMMappedFiles++withOptions :: GmEnv m => (Options -> Options) -> m a -> m a+withOptions changeOpt action = gmeLocal changeEnv action+  where+    changeEnv e = e { gmOptions = changeOpt opt }+      where+        opt = gmOptions e
+ core/GhcMod/Options/DocUtils.hs view
@@ -0,0 +1,48 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015  Nikolay Yakimov <root@livid.pp.ru>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++module GhcMod.Options.DocUtils (+  ($$),+  ($$$),+  (<=>),+  (<$$>),+  (<||>)+) where++import Options.Applicative+import Data.Monoid+import Prelude++infixl 6 <||>+infixr 7 <$$>+infixr 7 $$+infixr 8 <=>+infixr 9 $$$++($$) :: (a -> b) -> a -> b+($$) = ($)++($$$) :: (a -> b) -> a -> b+($$$) = ($)++(<||>) :: Alternative a => a b -> a b -> a b+(<||>) = (<|>)++(<=>) :: Monoid m => m -> m -> m+(<=>) = (<>)++(<$$>) :: Functor f => (a -> b) -> f a -> f b+(<$$>) = (<$>)
+ core/GhcMod/Options/Help.hs view
@@ -0,0 +1,79 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015  Nikolay Yakimov <root@livid.pp.ru>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.+{-# LANGUAGE OverloadedStrings, FlexibleInstances, GeneralizedNewtypeDeriving #-}++module GhcMod.Options.Help where++import Options.Applicative+import Options.Applicative.Help.Pretty (Doc)+import qualified Options.Applicative.Help.Pretty as PP+import Control.Monad.State+import GHC.Exts( IsString(..) )+import Data.Maybe+import Data.Monoid+import Prelude++newtype MyDocM s a = MyDoc {unwrapState :: State s a}+  deriving (Monad, Functor, Applicative, MonadState s)+type MyDoc = MyDocM (Maybe Doc) ()++instance IsString (MyDocM (Maybe Doc) a) where+    fromString = append . para++instance Monoid (MyDocM (Maybe Doc) ()) where+  mappend a b = append $ doc a <> doc b+  mempty = append PP.empty++para :: String -> Doc+para = PP.fillSep . map PP.text . words++append :: Doc -> MyDocM (Maybe Doc) a+append s = modify m >> return undefined+  where+    m :: Maybe Doc -> Maybe Doc+    m Nothing = Just s+    m (Just old) = Just $ old PP..$. s++infixr 7 \\+(\\) :: MyDoc -> MyDoc -> MyDoc+(\\) a b = append $ doc a PP.<+> doc b++doc :: MyDoc -> Doc+doc = fromMaybe PP.empty . flip execState Nothing . unwrapState++help' :: MyDoc -> Mod f a+help' = helpDoc . Just . doc++desc :: MyDoc -> InfoMod a+desc = footerDoc . Just . doc . indent 2++code :: MyDoc -> MyDoc+code x = do+  _ <- " "+  indent 4 x+  " "++progDesc' :: MyDoc -> InfoMod a+progDesc' = progDescDoc . Just . doc++indent :: Int -> MyDoc -> MyDoc+indent n = append . PP.indent n . doc++int' :: Int -> MyDoc+int' = append . PP.int++para' :: String -> MyDoc+para' = append . para
+ core/GhcMod/Options/Options.hs view
@@ -0,0 +1,177 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015  Nikolay Yakimov <root@livid.pp.ru>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}++module GhcMod.Options.Options (+    globalArgSpec+  , parseCmdLineOptions+) where++import Options.Applicative+import Options.Applicative.Types+import GhcMod.Types+import Control.Arrow+import Data.Char (toUpper, toLower)+import Data.List (intercalate)+import GhcMod.Read+import GhcMod.Options.DocUtils+import GhcMod.Options.Help+import Data.Monoid+import Prelude++-- | Parse a set of arguments according to the ghc-mod CLI flag spec, producing+-- @Options@ set accordingly.+parseCmdLineOptions :: [String] -> Maybe Options+parseCmdLineOptions = getParseResult . execParserPure (prefs mempty) (info globalArgSpec mempty)++splitOn :: Eq a => a -> [a] -> ([a], [a])+splitOn c = second (drop 1) . break (==c)++logLevelParser :: Parser GmLogLevel+logLevelParser =+    logLevelSwitch <*>+           logLevelOption+      <||> silentSwitch+  where+    logLevelOption =+      option parseLL+        $$  long "verbose"+        <=> metavar "LEVEL"+        <=> value GmWarning+        <=> showDefaultWith showLL+        <=> help' $$$ do+          "Set log level ("+            <> int' (fromEnum (minBound :: GmLogLevel))+            <> "-"+            <> int' (fromEnum (maxBound :: GmLogLevel))+            <> ")"+          "You can also use strings (case-insensitive):"+          para'+            $ intercalate ", "+            $ map showLL ([minBound..maxBound] :: [GmLogLevel])+    logLevelSwitch =+      repeatAp succ' . length <$> many $$ flag' ()+        $$  short 'v'+        <=> help "Increase log level"+    silentSwitch = flag' GmSilent+        $$  long "silent"+        <=> short 's'+        <=> help "Be silent, set log level to 'silent'"+    showLL = drop 2 . map toLower . show+    repeatAp f n = foldr (.) id (replicate n f)+    succ' x | x == maxBound = x+            | otherwise     = succ x+    parseLL = do+      v <- readerAsk+      let+        il'= toEnum . min maxBound <$> readMaybe v+        ll' = readMaybe ("Gm" ++ capFirst v)+      maybe (readerError $ "Not a log level \"" ++ v ++ "\"") return $ ll' <|> il'+    capFirst (h:t) = toUpper h : map toLower t+    capFirst [] = []++outputOptsSpec :: Parser OutputOpts+outputOptsSpec = OutputOpts+      <$> logLevelParser+      <*> flag PlainStyle LispStyle+          $$  long "tolisp"+          <=> short 'l'+          <=> help "Format output as an S-Expression"+      <*> LineSeparator <$$> strOption+          $$  long "boundary"+          <=> long "line-separator"+          <=> short 'b'+          <=> metavar "SEP"+          <=> value "\0"+          <=> showDefault+          <=> help "Output line separator"+      <*> optional $$ splitOn ',' <$$> strOption+          $$  long "line-prefix"+          <=> metavar "OUT,ERR"+          <=> help "Output prefixes"++programsArgSpec :: Parser Programs+programsArgSpec = Programs+      <$> strOption+          $$  long "with-ghc"+          <=> value "ghc"+          <=> showDefault+          <=> help "GHC executable to use"+      <*> strOption+          $$  long "with-ghc-pkg"+          <=> value "ghc-pkg"+          <=> showDefault+          <=> help "ghc-pkg executable to use (only needed when guessing from GHC path fails)"+      <*> strOption+          $$  long "with-cabal"+          <=> value "cabal"+          <=> showDefault+          <=> help "cabal-install executable to use"+      <*> strOption+          $$  long "with-stack"+          <=> value "stack"+          <=> showDefault+          <=> help "stack executable to use"++-- | An optparse-applicative @Parser@ sepcification for @Options@ so that+-- applications making use of the ghc-mod API can have a consistent way of+-- parsing global options.+globalArgSpec :: Parser Options+globalArgSpec = Options+      <$> outputOptsSpec+      <*> programsArgSpec+      <*> many $$ strOption+          $$  long "ghcOpt"+          <=> long "ghc-option"+          <=> short 'g'+          <=> metavar "OPT"+          <=> help "Option to be passed to GHC"+      <*> many fileMappingSpec+      <*> strOption+          $$  long "encoding"+          <=> value "UTF-8"+          <=> showDefault+          <=> help "I/O encoding"+      <*> switch+          $$  long "stack-build-deps"+          <=> showDefault+          <=> help "Build dependencies if needed when using stack"+  where+    fileMappingSpec =+      getFileMapping . splitOn '=' <$> strOption+        $$  long "map-file"+        <=> metavar "MAPPING"+        <=> fileMappingHelp+    fileMappingHelp = help' $ do+        "Redirect one file to another"+        "--map-file \"file1.hs=file2.hs\""+        indent 4 $ do+          "can be used to tell ghc-mod"+            \\ "that it should take source code"+            \\ "for `file1.hs` from `file2.hs`."+          "`file1.hs` can be either full path,"+            \\ "or path relative to project root."+          "`file2.hs` has to be either relative to project root,"+            \\  "or full path (preferred)"+        "--map-file \"file.hs\""+        indent 4 $ do+          "can be used to tell ghc-mod that it should take"+            \\ "source code for `file.hs` from stdin. File end"+            \\ "marker is `\\n\\EOT\\n`, i.e. `\\x0A\\x04\\x0A`."+            \\ "`file.hs` may or may not exist, and should be"+            \\ "either full path, or relative to project root."+    getFileMapping = second (\i -> if null i then Nothing else Just i)
+ core/GhcMod/Output.hs view
@@ -0,0 +1,243 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++-- Derived from process:System.Process+-- Copyright (c) The University of Glasgow 2004-2008++{-# LANGUAGE FlexibleInstances #-}+module GhcMod.Output (+    gmPutStr+  , gmErrStr+  , gmPutStrLn+  , gmErrStrLn++  , gmPutStrIO+  , gmErrStrIO++  , gmReadProcess+  , gmReadProcess'++  , stdoutGateway+  , flushStdoutGateway+  ) where++import Data.List+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as BS+import qualified Data.Label as L+import qualified Data.Label.Base as LB+import System.IO+import System.Exit+import System.Process+import Control.Monad+import Control.Monad.State.Strict+import Control.DeepSeq+import Control.Exception+import Control.Concurrent (forkIO, killThread)+import Control.Concurrent.MVar+import Control.Concurrent.Chan+import Pipes+import Pipes.Lift+import Prelude++import GhcMod.Types hiding (LineSeparator, MonadIO(..))+import GhcMod.Monad.Types hiding (MonadIO(..))+import GhcMod.Gap ()++class ProcessOutput a where+  hGetContents' :: Handle -> IO a++instance ProcessOutput String where+  hGetContents' = hGetContents++instance ProcessOutput ByteString where+  hGetContents' = BS.hGetContents++outputFns :: (GmOut m, MonadIO m')+          => m (String -> m' (), String -> m' ())+outputFns =+  outputFns' `liftM` gmoAsk++outputFns' ::+  MonadIO m => GhcModOut -> (String -> m (), String -> m ())+outputFns' (GhcModOut oopts c)  = let+  OutputOpts {..} = oopts+ in+  case ooptLinePrefix of+    Nothing -> stdioOutputFns+    Just _  -> chanOutputFns c++stdioOutputFns :: MonadIO m => (String -> m (), String -> m ())+stdioOutputFns =+    ( liftIO . putStr+    , liftIO . hPutStr stderr+    )++chanOutputFns :: MonadIO m+              => Chan (Either (MVar ()) (GmStream, String))+              -> (String -> m (), String -> m ())+chanOutputFns c = (write GmOutStream, write GmErrStream)+ where+   write stream s = liftIO $ writeChan c $ Right $ (stream,s)++gmPutStr, gmPutStrLn, gmErrStr, gmErrStrLn+    :: (MonadIO m, GmOut m) => String -> m ()++gmPutStr str = do+  putOut <- gmPutStrIO+  putOut str++gmErrStr str = do+  putErr <- gmErrStrIO+  putErr str++gmPutStrLn = gmPutStr . (++"\n")+gmErrStrLn = gmErrStr . (++"\n")++gmPutStrIO, gmErrStrIO :: (GmOut m, MonadIO mi) => m (String -> mi ())++gmPutStrIO = fst `liftM` outputFns+gmErrStrIO = snd `liftM` outputFns+++gmReadProcess :: GmOut m => m (FilePath -> [String] -> String -> IO String)+gmReadProcess = do+  GhcModOut {..} <- gmoAsk+  case ooptLinePrefix gmoOptions of+    Just _ ->+        readProcessStderrChan+    Nothing ->+        return $ readProcess++gmReadProcess' :: GmOut m => m (FilePath -> [String] -> String -> IO ByteString)+gmReadProcess' = readProcessStderrChan++flushStdoutGateway :: Chan (Either (MVar ()) (GmStream, String)) -> IO ()+flushStdoutGateway c = do+  mv <- newEmptyMVar+  writeChan c $ Left mv+  takeMVar mv++type Line = String++stdoutGateway :: (String, String) -> Chan (Either (MVar ()) (GmStream, String)) -> IO ()+stdoutGateway (outPf, errPf) chan = do+  runEffect $ commandProc >-> evalStateP ("","") seperateStreams+ where+   commandProc :: Producer (Either (MVar ()) (GmStream, String)) IO ()+   commandProc = do+     cmd <- liftIO $ readChan chan+     case cmd of+       Left mv -> do+           yield $ Left mv+       Right input -> do+           yield $ Right input+           commandProc++   seperateStreams :: Consumer (Either (MVar ()) (GmStream, String)) (StateT (String, String) IO) ()+   seperateStreams  = do+       ecmd <- await+       case ecmd of+         Left mv -> do+           -- flush buffers+           (\s -> lift $ zoom (streamLens s) $ sGetLine Nothing)+               `mapM_` [GmOutStream, GmErrStream]++           liftIO $ putMVar mv ()+         Right (stream, str) -> do+           ls <- lift $ zoom (streamLens stream) $ sGetLine (Just str)+           case ls of+               [] -> return ()+               _  -> liftIO $ putStr $ unlines $ map (streamPf stream++) ls++           liftIO $ hFlush stdout+           seperateStreams++   sGetLine :: (Maybe String) -> StateT String IO [Line]+   sGetLine mstr' = do+     buf <- get+     let mstr = (buf++) `liftM` mstr'+     case mstr of+       Nothing -> put "" >> return [buf]+       Just "" -> return []+       Just s | last s == '\n' -> put "" >> return (lines s)+              | otherwise -> do+                  let (p:ls') = reverse $ lines s+                  put p+                  return $ reverse $ ls'++   streamLens GmOutStream = LB.fst+   streamLens GmErrStream = LB.snd++   streamPf GmOutStream = outPf+   streamPf GmErrStream = errPf++zoom :: Monad m => (f L.:-> o) -> StateT o m a -> StateT f m a+zoom l (StateT a) =+    StateT $ \f -> do+      (a', s') <- a $ L.get l f+      return (a', L.set l s' f)++readProcessStderrChan ::+    (GmOut m, ProcessOutput a, NFData a) => m (FilePath -> [String] -> String -> IO a)+readProcessStderrChan = do+  (_, e :: String -> IO ()) <- outputFns+  return $ readProcessStderrChan' e++readProcessStderrChan' :: (ProcessOutput a, NFData a) =>+    (String -> IO ()) -> FilePath -> [String] -> String -> IO a+readProcessStderrChan' putErr exe args input = do+     let cp = (proc exe args) {+                std_out = CreatePipe+              , std_err = CreatePipe+              , std_in  = CreatePipe+              }+     (Just i, Just o, Just e, h) <- createProcess cp++     _ <- forkIO $ reader e++     output  <- hGetContents' o+     withForkWait (evaluate $ rnf output) $ \waitOut -> do++       -- now write any input+       unless (null input) $+         ignoreSEx $ hPutStr i input+       -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE+       ignoreSEx $ hClose i++       -- wait on the output+       waitOut+       hClose o++     res <- waitForProcess h+     case res of+       ExitFailure rv ->+           throw $ GMEProcess "readProcessStderrChan" exe args $ Left rv+       ExitSuccess ->+           return output+    where+      ignoreSEx = handle (\(SomeException _) -> return ())+      reader h = ignoreSEx $ do+        putErr . (++"\n") =<< hGetLine h+        reader h++withForkWait :: IO () -> (IO () ->  IO a) -> IO a+withForkWait async body = do+  waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))+  mask $ \restore -> do+    tid <- forkIO $ try (restore async) >>= putMVar waitVar+    let wait = takeMVar waitVar >>= either throwIO return+    restore (body wait) `onException` killThread tid
+ core/GhcMod/PathsAndFiles.hs view
@@ -0,0 +1,242 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++module GhcMod.PathsAndFiles (+    module GhcMod.PathsAndFiles+  , module GhcMod.Caching+  ) where++import Config (cProjectVersion)+import Control.Arrow (second)+import Control.Applicative+import Control.Exception as E+import Control.Monad+import Control.Monad.Trans.Maybe+import Data.List+import Data.Char+import Data.Maybe+import Data.Traversable hiding (mapM)+import Distribution.Helper (buildPlatform)+import System.Directory+import System.FilePath+import System.Process++import GhcMod.Types+import GhcMod.Caching+import qualified GhcMod.Utils as U+import Utils (mightExist)+import Prelude++-- | Guaranteed to be a path to a directory with no trailing slash.+type DirPath = FilePath++-- | Guaranteed to be the name of a file only (no slashes).+type FileName = String++-- | @findCabalFiles dir@. Searches for a @.cabal@ files in @dir@'s parent+-- directories. The first parent directory containing more than one cabal file+-- is assumed to be the project directory. If only one cabal file exists in this+-- directory it is returned otherwise @findCabalFiles@ throws 'GMENoCabalFile'+-- or 'GMETooManyCabalFiles'+findCabalFile :: FilePath -> IO (Maybe FilePath)+findCabalFile dir = findFileInParentsP isCabalFile pick dir+  where+    pick [] = Nothing+    pick [cf] = Just cf+    pick cfs  = throw $ GMETooManyCabalFiles cfs++findStackConfigFile :: FilePath -> IO (Maybe FilePath)+findStackConfigFile dir =+    findFileInParentsP (=="stack.yaml") pick dir+  where+    pick []     = Nothing+    pick (sf:_) = Just sf++findCabalSandboxDir :: FilePath -> IO (Maybe FilePath)+findCabalSandboxDir dir =+  fmap takeDirectory <$> findFileInParentsP isSandboxConfig pick dir+ where+   isSandboxConfig = (==sandboxConfigFileName)+   pick []     = Nothing+   pick (sc:_) = Just sc++findCustomPackageDbFile :: FilePath -> IO (Maybe FilePath)+findCustomPackageDbFile dir =+    mightExist $ dir </> "ghc-mod.package-db-stack"++-- | Get path to sandbox config file+getSandboxDb :: Cradle -> IO (Maybe GhcPkgDb)+getSandboxDb crdl = do+  mConf <- traverse readFile =<< mightExist (sandboxConfigFile crdl)+  bp <- buildPlatform readProcess+  return $ PackageDb . fixPkgDbVer bp <$> (extractSandboxDbDir =<< mConf)++ where+   fixPkgDbVer bp dir =+       case takeFileName dir == ghcSandboxPkgDbDir bp of+         True -> dir+         False -> takeDirectory dir </> ghcSandboxPkgDbDir bp++-- | Extract the sandbox package db directory from the cabal.sandbox.config+-- file. Exception is thrown if the sandbox config file is broken.+extractSandboxDbDir :: String -> Maybe FilePath+extractSandboxDbDir conf = extractValue <$> parse conf+  where+    key = "package-db:"+    keyLen = length key++    parse = listToMaybe . filter (key `isPrefixOf`) . lines+    extractValue = U.dropWhileEnd isSpace . dropWhile isSpace . drop keyLen+++-- |+-- >>> isCabalFile "/home/user/.cabal"+-- False+isCabalFile :: FilePath -> Bool+isCabalFile f = takeExtension' f == ".cabal"++-- |+-- >>> takeExtension' "/some/dir/bla.cabal"+-- ".cabal"+--+-- >>> takeExtension' "some/reldir/bla.cabal"+-- ".cabal"+--+-- >>> takeExtension' "bla.cabal"+-- ".cabal"+--+-- >>> takeExtension' ".cabal"+-- ""+takeExtension' :: FilePath -> String+takeExtension' p =+    if takeFileName p == takeExtension p+      then "" -- just ".cabal" is not a valid cabal file+      else takeExtension p++-- | @findFileInParentsP p r dir@ Look for files satisfying @p@ in @dir@ and all+-- it's parent directories. Files found to satisfy @p@ in a given directory are+-- passed to @r@ and if this yields a 'Just' value the search finishes early+-- without examinig any more directories and this value is returned.+findFileInParentsP :: (FilePath -> Bool)+                   -> ([FilePath] -> Maybe a)+                   -> FilePath+                   -> IO (Maybe a)+findFileInParentsP p r dir = runMaybeT $+    join $ msum <$> map (MaybeT . fmap r) <$> liftIO (findFilesInParentsP p dir)++-- | @findFilesInParentsP p dir@ Look for files satisfying @p@ in @dir@ and all+-- it's parent directories.+findFilesInParentsP :: (FilePath -> Bool) -> FilePath+                   -> IO [IO [FilePath]]+findFilesInParentsP p dir' = U.makeAbsolute' dir' >>= \dir -> return $+    map (\d -> (map (d </>)) <$> getFilesP p d) $ parents dir++-- | @getFilesP p dir@. Find all __files__ satisfying @p@ in @.cabal@ in @dir@.+getFilesP :: (FilePath -> Bool) -> DirPath -> IO [FileName]+getFilesP p dir = filterM p' =<< getDirectoryContentsSafe+ where+   p' fn = do+     (p fn && ) <$> doesFileExist (dir </> fn)+   getDirectoryContentsSafe = do+     rdable <- readable <$> getPermissions dir+     if rdable+        then getDirectoryContents dir+        else return []++-- | @parents dir@. Returns all parent directories of @dir@ including @dir@.+--+-- Examples+--+-- >>> parents "foo"+-- ["foo"]+--+-- >>> parents "/foo"+-- ["/foo","/"]+--+-- >>> parents "/foo/bar"+-- ["/foo/bar","/foo","/"]+--+-- >>> parents "foo/bar"+-- ["foo/bar","foo"]+parents :: FilePath -> [FilePath]+parents "" = []+parents dir' =+    let (drive, dir) = splitDrive $ normalise $ dropTrailingPathSeparator dir'+    in map (joinDrive drive) $ parents' $ filter (/=".") $ splitDirectories dir+ where+   parents' :: [String] -> [FilePath]+   parents' [] | isAbsolute dir' = "":[]+   parents' [] = []+   parents' dir = [joinPath dir] ++ parents' (init dir)++----------------------------------------------------------------++setupConfigFile :: Cradle -> FilePath+setupConfigFile crdl =+    cradleRootDir crdl </> setupConfigPath (cradleDistDir crdl)++sandboxConfigFile :: Cradle -> FilePath+sandboxConfigFile crdl = cradleRootDir crdl </> sandboxConfigFileName++sandboxConfigFileName :: String+sandboxConfigFileName = "cabal.sandbox.config"++-- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@+setupConfigPath :: FilePath -> FilePath+setupConfigPath dist = dist </> "setup-config"+ -- localBuildInfoFile defaultDistPref++macrosHeaderPath :: FilePath+macrosHeaderPath = autogenModulesDir </> "cabal_macros.h"++autogenModulePath :: String -> String+autogenModulePath pkg_name =+    autogenModulesDir </> ("Paths_" ++ map fixchar pkg_name) <.> ".hs"+  where fixchar '-' = '_'+        fixchar c   = c++autogenModulesDir :: FilePath+autogenModulesDir = "build" </> "autogen"++ghcSandboxPkgDbDir :: String -> String+ghcSandboxPkgDbDir buildPlatf = do+    buildPlatf ++ "-ghc-" ++ cProjectVersion ++ "-packages.conf.d"++packageCache :: String+packageCache = "package.cache"++-- | Filename of the symbol table cache file.+symbolCache :: Cradle -> FilePath+symbolCache crdl = cradleRootDir crdl </> cradleDistDir crdl </> symbolCacheFile++symbolCacheFile :: String+symbolCacheFile = "ghc-mod.symbol-cache"++resolvedComponentsCacheFile :: FilePath -> FilePath+resolvedComponentsCacheFile dist =+    setupConfigPath dist <.> "ghc-mod.resolved-components"++cabalHelperCacheFile :: FilePath -> FilePath+cabalHelperCacheFile dist =+    setupConfigPath dist <.> "ghc-mod.cabal-components"++mergedPkgOptsCacheFile :: FilePath -> FilePath+mergedPkgOptsCacheFile dist =+    setupConfigPath dist <.> "ghc-mod.package-options"++pkgDbStackCacheFile :: FilePath -> FilePath+pkgDbStackCacheFile dist =+    setupConfigPath dist <.> "ghc-mod.package-db-stack"
+ core/GhcMod/Pretty.hs view
@@ -0,0 +1,90 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++module GhcMod.Pretty+  ( renderGm+  , renderSDoc+  , gmComponentNameDoc+  , gmLogLevelDoc+  , (<+>:)+  , fnDoc+  , showToDoc+  , warnDoc+  , strLnDoc+  , strDoc+  ) where++import Control.Arrow hiding ((<+>))+import Data.Char+import Data.List+import Distribution.Helper+import Pretty+import GHC+import Outputable (SDoc, withPprStyleDoc)++import GhcMod.Types+import GhcMod.Doc+import GhcMod.Gap (renderGm)++renderSDoc :: GhcMonad m => SDoc -> m Doc+renderSDoc sdoc = do+  df <- getSessionDynFlags+  ppsty <- getStyle+  return $ withPprStyleDoc df ppsty sdoc++gmComponentNameDoc :: ChComponentName -> Doc+gmComponentNameDoc ChSetupHsName   = text $ "Setup.hs"+gmComponentNameDoc (ChLibName "")  = text $ "library"+gmComponentNameDoc (ChLibName n)   = text $ "library:" ++ n+gmComponentNameDoc (ChExeName n)   = text $ "exe:" ++ n+gmComponentNameDoc (ChTestName n)  = text $ "test:" ++ n+gmComponentNameDoc (ChBenchName n) = text $ "bench:" ++ n++gmLogLevelDoc :: GmLogLevel -> Doc+gmLogLevelDoc GmSilent    = error "GmSilent MUST not be used for log messages"+gmLogLevelDoc GmPanic     = text "PANIC"+gmLogLevelDoc GmException = text "EXCEPTION"+gmLogLevelDoc GmError     = text "ERROR"+gmLogLevelDoc GmWarning   = text "Warning"+gmLogLevelDoc GmInfo      = text "info"+gmLogLevelDoc GmDebug     = text "DEBUG"+gmLogLevelDoc GmVomit     = text "VOMIT"++infixl 6 <+>:+(<+>:) :: Doc -> Doc -> Doc+a <+>: b = (a <> colon) <+> b++fnDoc :: FilePath -> Doc+fnDoc = doubleQuotes . text++showToDoc :: Show a => a -> Doc+showToDoc = strLnDoc . show++warnDoc :: Doc -> Doc+warnDoc d = text "Warning" <+>: d++strLnDoc :: String -> Doc+strLnDoc str = doc (dropWhileEnd isSpace str)+ where+   doc = lines >>> map text >>> foldr ($+$) empty++strDoc :: String -> Doc+strDoc str = doc (dropWhileEnd isSpace str)+ where+   doc :: String -> Doc+   doc = lines+         >>> map (words >>> map text >>> fsep)+         >>> \l -> case l of (x:xs) -> hang x 4 (vcat xs); [] -> empty
+ core/GhcMod/Read.hs view
@@ -0,0 +1,106 @@+module GhcMod.Read where++import Text.Read (readPrec_to_S, readPrec, minPrec)+import qualified Text.ParserCombinators.ReadP as P+import Text.ParserCombinators.ReadPrec (lift)++-- This library (libraries/base) is derived from code from several+-- sources:++--   * Code from the GHC project which is largely (c) The University of+--     Glasgow, and distributable under a BSD-style license (see below),++--   * Code from the Haskell 98 Report which is (c) Simon Peyton Jones+--     and freely redistributable (but see the full license for+--     restrictions).++--   * Code from the Haskell Foreign Function Interface specification,+--     which is (c) Manuel M. T. Chakravarty and freely redistributable+--     (but see the full license for restrictions).++-- The full text of these licenses is reproduced below.  All of the+-- licenses are BSD-style or compatible.++-- -----------------------------------------------------------------------------++-- The Glasgow Haskell Compiler License++-- Copyright 2004, The University Court of the University of Glasgow.+-- All rights reserved.++-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:++-- - Redistributions of source code must retain the above copyright notice,+-- this list of conditions and the following disclaimer.++-- - Redistributions in binary form must reproduce the above copyright notice,+-- this list of conditions and the following disclaimer in the documentation+-- and/or other materials provided with the distribution.++-- - Neither name of the University nor the names of its contributors may be+-- used to endorse or promote products derived from this software without+-- specific prior written permission.++-- THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+-- GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+-- INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+-- FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+-- UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+-- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+-- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+-- DAMAGE.++-- -----------------------------------------------------------------------------++-- Code derived from the document "Report on the Programming Language+-- Haskell 98", is distributed under the following license:++--   Copyright (c) 2002 Simon Peyton Jones++--   The authors intend this Report to belong to the entire Haskell+--   community, and so we grant permission to copy and distribute it for+--   any purpose, provided that it is reproduced in its entirety,+--   including this Notice.  Modified versions of this Report may also be+--   copied and distributed for any purpose, provided that the modified+--   version is clearly presented as such, and that it does not claim to+--   be a definition of the Haskell 98 Language.++-- -----------------------------------------------------------------------------++-- Code derived from the document "The Haskell 98 Foreign Function+-- Interface, An Addendum to the Haskell 98 Report" is distributed under+-- the following license:++--   Copyright (c) 2002 Manuel M. T. Chakravarty++--   The authors intend this Report to belong to the entire Haskell+--   community, and so we grant permission to copy and distribute it for+--   any purpose, provided that it is reproduced in its entirety,+--   including this Notice.  Modified versions of this Report may also be+--   copied and distributed for any purpose, provided that the modified+--   version is clearly presented as such, and that it does not claim to+--   be a definition of the Haskell 98 Foreign Function Interface.++-- -----------------------------------------------------------------------------++readEither :: Read a => String -> Either String a+readEither s =+  case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of+    [x] -> Right x+    []  -> Left "Prelude.read: no parse"+    _   -> Left "Prelude.read: ambiguous parse"+ where+  read' =+    do x <- readPrec+       lift P.skipSpaces+       return x++readMaybe :: Read a => String -> Maybe a+readMaybe s = case readEither s of+                Left _  -> Nothing+                Right a -> Just a
+ core/GhcMod/SrcUtils.hs view
@@ -0,0 +1,191 @@+-- TODO: remove CPP once Gap(ed)+{-# LANGUAGE CPP, TupleSections, FlexibleInstances, Rank2Types #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module GhcMod.SrcUtils where++import Control.Applicative+import CoreUtils (exprType)+import Data.Generics+import Data.Maybe+import Data.Ord as O+import GHC (LHsExpr, LPat, Id, DynFlags, SrcSpan, Type, Located, ParsedSource, RenamedSource, TypecheckedSource, GenLocated(L))+import Var (Var)+import qualified GHC as G+import qualified Var as G+import qualified Type as G+import GHC.SYB.Utils+import GhcMonad+import qualified Language.Haskell.Exts as HE+import GhcMod.Doc+import GhcMod.Gap+import qualified GhcMod.Gap as Gap+import OccName (OccName)+import Outputable (PprStyle)+import TcHsSyn (hsPatType)+import Prelude+import Control.Monad+import Data.List (nub)+import Control.Arrow+import qualified Data.Map as M++----------------------------------------------------------------++instance HasType (LHsExpr Id) where+    getType tcm e = do+        hs_env <- G.getSession+        mbe <- liftIO $ Gap.deSugar tcm e hs_env+        return $ (G.getLoc e, ) <$> CoreUtils.exprType <$> mbe++instance HasType (LPat Id) where+    getType _ (G.L spn pat) = return $ Just (spn, hsPatType pat)++----------------------------------------------------------------++-- | Stores mapping from monomorphic to polymorphic types+type CstGenQS = M.Map Var Type+-- | Generic type to simplify SYB definition+type CstGenQT a = forall m. GhcMonad m => a Id -> CstGenQS -> (m [(SrcSpan, Type)], CstGenQS)++collectSpansTypes :: (GhcMonad m) => Bool -> G.TypecheckedModule -> (Int, Int) -> m [(SrcSpan, Type)]+collectSpansTypes withConstraints tcs lc =+  -- This walks AST top-down, left-to-right, while carrying CstGenQS down the tree+  -- (but not left-to-right)+  everythingStagedWithContext TypeChecker M.empty (liftM2 (++))+    (return [])+    ((return [],)+      `mkQ`  (hsBind    :: CstGenQT G.LHsBind) -- matches on binds+      `extQ` (genericCT :: CstGenQT G.LHsExpr) -- matches on expressions+      `extQ` (genericCT :: CstGenQT G.LPat) -- matches on patterns+      )+    (G.tm_typechecked_source tcs)+  where+    -- Helper function to insert mapping into CstGenQS+    insExp x = M.insert (G.abe_mono x) (G.varType $ G.abe_poly x)+    -- If there is AbsBinds here, insert mapping into CstGenQS if needed+    hsBind (L _ G.AbsBinds{abs_exports = es'}) s+      | withConstraints = (return [], foldr insExp s es')+      | otherwise       = (return [], s)+#if __GLASGOW_HASKELL__ >= 800+    -- TODO: move to Gap+    -- Note: this deals with bindings with explicit type signature, e.g.+    --    double :: Num a => a -> a+    --    double x = 2*x+    hsBind (L _ G.AbsBindsSig{abs_sig_export = poly, abs_sig_bind = bind}) s+      | withConstraints =+          let new_s =+                case bind of+                  G.L _ G.FunBind{fun_id = i} -> M.insert (G.unLoc i) (G.varType poly) s+                  _ -> s+          in (return [], new_s)+      | otherwise       = (return [], s)+#endif+    -- Otherwise, it's the same as other cases+    hsBind x s = genericCT x s+    -- Generic SYB function to get type+    genericCT x s+      | withConstraints+      = (maybe [] (uncurry $ constrainedType (collectBinders x) s) <$> getType' x, s)+      | otherwise = (maybeToList <$> getType' x, s)+    -- Collects everything with Id from LHsBind, LHsExpr, or LPat+    collectBinders :: Data a => a -> [Id]+    collectBinders = listifyStaged TypeChecker (const True)+    -- Gets monomorphic type with location+    getType' x@(L spn _)+      | G.isGoodSrcSpan spn && spn `G.spans` lc+      = getType tcs x+      | otherwise = return Nothing+    -- Gets constrained type+    constrainedType :: [Var] -- ^ Binders in expression, i.e. anything with Id+                    -> CstGenQS -- ^ Map from Id to polymorphic type+                    -> SrcSpan -- ^ extent of expression, copied to result+                    -> Type -- ^ monomorphic type+                    -> [(SrcSpan, Type)] -- ^ result+    constrainedType pids s spn genTyp =+      let+        -- runs build on every binder.+        ctys  = mapMaybe build (nub pids)+        -- Computes constrained type for x. Returns (constraints, substitutions)+        -- Substitutions are needed because type variables don't match+        -- between polymorphic and monomorphic types.+        -- E.g. poly type might be `Monad m => m ()`, while monomorphic might be `f ()`+        build x | Just cti <- x `M.lookup` s+                = let+                    (preds', ctt) = getPreds cti+                    -- list of type variables in monomorphic type+                    vts = listifyStaged TypeChecker G.isTyVar $ G.varType x+                    -- list of type variables in polymorphic type+                    tvm = listifyStaged TypeChecker G.isTyVarTy ctt+                  in Just (preds', zip vts tvm)+                | otherwise = Nothing+        -- list of constraints+        preds = concatMap fst ctys+        -- Type variable substitutions+#if __GLASGOW_HASKELL__ >= 800+ -- TODO: move to Gap+        subs  = G.mkTvSubstPrs $ concatMap snd ctys+#else+        subs  = G.mkTopTvSubst $ concatMap snd ctys+#endif+        -- Constrained type+        ty    = G.substTy subs $ G.mkFunTys preds genTyp+      in [(spn, ty)]+    -- Splits a given type into list of constraints and simple type. Drops foralls.+    getPreds :: Type -> ([Type], Type)+    getPreds x | G.isForAllTy x = getPreds $ G.dropForAlls x+               | Just (c, t) <- G.splitFunTy_maybe x+               , G.isPredTy c = first (c:) $ getPreds t+               | otherwise = ([], x)++listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a]+listifySpans tcs lc = listifyStaged TypeChecker p tcs+  where+    p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc++listifyParsedSpans :: Typeable a => ParsedSource -> (Int, Int) -> [Located a]+listifyParsedSpans pcs lc = listifyStaged Parser p pcs+  where+    p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc++listifyRenamedSpans :: Typeable a => RenamedSource -> (Int, Int) -> [Located a]+listifyRenamedSpans pcs lc = listifyStaged Renamer p pcs+  where+    p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc++listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r]+listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x]))++cmp :: SrcSpan -> SrcSpan -> Ordering+cmp a b+  | a `G.isSubspanOf` b = O.LT+  | b `G.isSubspanOf` a = O.GT+  | otherwise           = O.EQ++toTup :: DynFlags -> PprStyle -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String)+toTup dflag style (spn, typ) = (fourInts spn, pretty dflag style typ)++fourInts :: SrcSpan -> (Int,Int,Int,Int)+fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan++fourIntsHE :: HE.SrcSpan -> (Int,Int,Int,Int)+fourIntsHE loc = ( HE.srcSpanStartLine loc, HE.srcSpanStartColumn loc+                 , HE.srcSpanEndLine loc, HE.srcSpanEndColumn loc)++-- Check whether (line,col) is inside a given SrcSpanInfo+typeSigInRangeHE :: Int -> Int -> HE.Decl HE.SrcSpanInfo -> Bool+typeSigInRangeHE lineNo colNo (HE.TypeSig (HE.SrcSpanInfo s _) _ _) =+  HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo)+typeSigInRangeHE lineNo colNo (HE.TypeFamDecl (HE.SrcSpanInfo s _) _ _ _) =+  HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo)+typeSigInRangeHE lineNo colNo (HE.DataFamDecl (HE.SrcSpanInfo s _) _ _ _) =+  HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo)+typeSigInRangeHE _  _ _= False++pretty :: DynFlags -> PprStyle -> Type -> String+pretty dflag style = showOneLine dflag style . Gap.typeForUser++showName :: DynFlags -> PprStyle -> G.Name -> String+showName dflag style name = showOneLine dflag style $ Gap.nameForUser name++showOccName :: DynFlags -> PprStyle -> OccName -> String+showOccName dflag style name = showOneLine dflag style $ Gap.occNameForUser name
+ core/GhcMod/Stack.hs view
@@ -0,0 +1,97 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++module GhcMod.Stack where++import Safe+import Control.Applicative+import Control.Exception as E+import Control.Monad+import Control.Monad.Trans.Maybe+import Control.Monad.Trans.Class+import Data.List+import Data.List.Split+import Data.Maybe+import System.Directory+import System.FilePath+import System.Info.Extra+import Exception++import GhcMod.Types+import GhcMod.Monad.Types+import GhcMod.Output+import GhcMod.Logging+import GhcMod.Error+import qualified GhcMod.Utils as U+import Prelude++patchStackPrograms :: (IOish m, GmOut m) => Cradle -> Programs -> m Programs+patchStackPrograms Cradle { cradleProject = (StackProject senv) } progs = do+  Just ghc <- getStackGhcPath senv+  Just ghcPkg <- getStackGhcPkgPath senv+  return $ progs {+      ghcProgram = ghc+    , ghcPkgProgram = ghcPkg+    }+patchStackPrograms _crdl progs = return progs++getStackEnv :: (IOish m, GmOut m, GmLog m)+            => FilePath -> FilePath -> m (Maybe StackEnv)+getStackEnv projdir stackProg = U.withDirectory_ projdir $ runMaybeT $ do+    env <- map (liToTup . splitOn ": ") . lines <$> readStack stackProg ["path"]+    let look k = fromJustNote "getStackEnv" $ lookup k env+    return StackEnv {+        seDistDir       = look "dist-dir"+      , seBinPath       = splitSearchPath $ look "bin-path"+      , seSnapshotPkgDb = look "snapshot-pkg-db"+      , seLocalPkgDb    = look "local-pkg-db"+      }+ where+   liToTup [k,v] = (k,v)+   liToTup [k] = (k, error "getStackEnv: missing key '"++k++"'")+   liToTup _ = error "getStackEnv"++getStackGhcPath :: IOish m => StackEnv -> m (Maybe FilePath)+getStackGhcPath = findExecutablesInStackBinPath "ghc"++getStackGhcPkgPath :: IOish m => StackEnv -> m (Maybe FilePath)+getStackGhcPkgPath = findExecutablesInStackBinPath  "ghc-pkg"++findExecutablesInStackBinPath :: IOish m => String -> StackEnv -> m (Maybe FilePath)+findExecutablesInStackBinPath exe StackEnv {..} =+    liftIO $ listToMaybe <$> findExecutablesInDirectories' seBinPath exe++findExecutablesInDirectories' :: [FilePath] -> String -> IO [FilePath]+findExecutablesInDirectories' path binary =+    U.findFilesWith' isExecutable path (binary <.> exeExtension')+   where isExecutable file = do+             perms <- getPermissions file+             return $ executable perms++         exeExtension' = if isWindows then "exe" else ""++readStack :: (IOish m, GmOut m, GmLog m)+          => FilePath -> [String] -> MaybeT m String+readStack exe args = do+  stack <- MaybeT $ liftIO $ findExecutable exe+  readProc <- lift gmReadProcess+  flip gcatch handler $ do+    liftIO $ evaluate =<< readProc stack args ""+ where+   handler (e :: IOError) = do+     gmLog GmWarning "readStack" $ gmeDoc $ exToErr e+     mzero+   exToErr = GMEStackBootstrap . GMEString . show
+ core/GhcMod/Target.hs view
@@ -0,0 +1,515 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP, ViewPatterns, NamedFieldPuns, RankNTypes #-}+module GhcMod.Target where++import Control.Arrow+import Control.Applicative+import Control.Category ((.))+import GHC+#if __GLASGOW_HASKELL__ >= 800+import GHC.LanguageExtensions+#endif+import GHC.Paths (libdir)+import SysTools+import DynFlags+import HscTypes+import Pretty++import GhcMod.DynFlags+import GhcMod.Monad.Types+import GhcMod.CabalHelper+import GhcMod.HomeModuleGraph+import GhcMod.PathsAndFiles+import GhcMod.GhcPkg+import GhcMod.Error+import GhcMod.Logging+import GhcMod.Types+import GhcMod.Utils as U+import GhcMod.FileMapping+import GhcMod.LightGhc+import GhcMod.CustomPackageDb+import GhcMod.Output++import Safe+import Data.Maybe+import Data.Monoid as Monoid+import Data.Either+import Data.Foldable as Foldable (foldrM)+import qualified Data.Foldable as Foldable+import Data.Traversable hiding (mapM, forM)+import Data.IORef+import Data.List+import Data.Map (Map)+import qualified Data.Map  as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Function (on)+import Distribution.Helper+import Prelude hiding ((.))++import System.Directory+import System.FilePath++runGmPkgGhc :: (IOish m, Gm m) => LightGhc a -> m a+runGmPkgGhc action = do+    pkgOpts <- packageGhcOptions+    withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action++initSession :: IOish m+            => [GHCOption]+            -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags)+            -> GhcModT m ()+initSession opts mdf = do+   s <- gmsGet+   case gmGhcSession s of+     Nothing -> do+         gmLog GmDebug "initSession" $ text "Session not initialized, creating new one"+         putNewSession s+     Just (GmGhcSession hsc_env_ref) -> do+         crdl <- cradle++         df <- liftIO $ hsc_dflags <$> readIORef hsc_env_ref+         changed <-+             withLightHscEnv' (initDF crdl) $ \hsc_env ->+               return $ not $ hsc_dflags hsc_env `eqDynFlags` df++         if changed+            then do+              gmLog GmDebug "initSession" $ text "Flags changed, creating new session"+              teardownSession hsc_env_ref+              putNewSession s+            else+              gmLog GmDebug "initSession" $ text "Session already initialized"+ where+   initDF Cradle { cradleTempDir } df =+       setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df)++   teardownSession hsc_env_ref = do+     hsc_env <- liftIO $ readIORef hsc_env_ref+     teardownLightEnv hsc_env++   putNewSession :: IOish m => GhcModState -> GhcModT m ()+   putNewSession s = do+     crdl <- cradle+     nhsc_env_ref <- liftIO . newIORef =<< newLightEnv (initDF crdl)+     runLightGhc' nhsc_env_ref $ setSessionDynFlags =<< getSessionDynFlags+     gmsPut s { gmGhcSession = Just $ GmGhcSession nhsc_env_ref }+++-- | Drop the currently active GHC session, the next that requires a GHC session+-- will initialize a new one.+dropSession :: IOish m => GhcModT m ()+dropSession = do+  s <- gmsGet+  case gmGhcSession s of+    Just (GmGhcSession ref) -> do+      -- TODO: This is still not enough, there seem to still be references to+      -- GHC's state around afterwards.+      liftIO $ writeIORef ref (error "HscEnv: session was dropped")+      -- Not available on ghc<7.8; didn't really help anyways+      -- liftIO $ setUnsafeGlobalDynFlags (error "DynFlags: session was dropped")+      gmsPut s { gmGhcSession = Nothing }++    Nothing -> return ()++-- | Run a GmlT action (i.e. a function in the GhcMonad) in the context+-- of certain files or modules+runGmlT :: IOish m => [Either FilePath ModuleName] -> GmlT m a -> GhcModT m a+runGmlT fns action = runGmlT' fns return action++-- | Run a GmlT action (i.e. a function in the GhcMonad) in the context+-- of certain files or modules, with updated GHC flags+runGmlT' :: IOish m+              => [Either FilePath ModuleName]+              -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags)+              -> GmlT m a+              -> GhcModT m a+runGmlT' fns mdf action = runGmlTWith fns mdf id action++-- | Run a GmlT action (i.e. a function in the GhcMonad) in the context+-- of certain files or modules, with updated GHC flags and a final+-- transformation+runGmlTWith :: IOish m+                 => [Either FilePath ModuleName]+                 -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags)+                 -> (GmlT m a -> GmlT m b)+                 -> GmlT m a+                 -> GhcModT m b+runGmlTWith efnmns' mdf wrapper action = do+    crdl <- cradle+    Options { optGhcUserOptions } <- options++    let (fns, mns) = partitionEithers efnmns'+        ccfns = map (cradleCurrentDir crdl </>) fns+    cfns <- mapM getCanonicalFileNameSafe ccfns+    let serfnmn = Set.fromList $ map Right mns ++ map Left cfns+    opts <- targetGhcOptions crdl serfnmn+    let opts' = opts ++ ["-O0"] ++ optGhcUserOptions++    gmVomit+      "session-ghc-options"+      (text "Initializing GHC session with following options")+      (intercalate " " $ map (("\""++) . (++"\"")) opts')++    GhcModLog { gmLogLevel = Just level } <- gmlHistory+    putErr <- gmErrStrIO+    let setLogger | level >= GmDebug = setDebugLogger putErr+                  | otherwise = setEmptyLogger++    initSession opts' $+        setHscNothing >>> setLogger >>> mdf++    mappedStrs <- getMMappedFilePaths+    let targetStrs = mappedStrs ++ map moduleNameString mns ++ cfns++    unGmlT $ wrapper $ do+      loadTargets opts targetStrs+      action++targetGhcOptions :: forall m. IOish m+                  => Cradle+                  -> Set (Either FilePath ModuleName)+                  -> GhcModT m [GHCOption]+targetGhcOptions crdl sefnmn = do+    when (Set.null sefnmn) $ error "targetGhcOptions: no targets given"++    case cradleProject crdl of+      proj+          | isCabalHelperProject proj -> cabalOpts crdl+          | otherwise -> sandboxOpts crdl+ where+   zipMap f l = l `zip` (f `map` l)++   cabalOpts :: Cradle -> GhcModT m [String]+   cabalOpts Cradle{..} = do+       mcs <- cabalResolvedComponents++       let mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn+           candidates = findCandidates $ map snd mdlcs++       let noCandidates = Set.null candidates+           noModuleHasAnyAssignment = all (Set.null . snd) mdlcs++       if noCandidates && noModuleHasAnyAssignment+          then do+            -- First component should be ChLibName, if no lib will take lexically first exe.+            let cns = filter (/= ChSetupHsName) $ Map.keys mcs++            gmLog GmDebug "" $ strDoc $ "Could not find a component assignment, falling back to picking library component in cabal file."+            return $ gmcGhcOpts $ fromJustNote "targetGhcOptions, no-assignment" $ Map.lookup (head cns) mcs+          else do+            when noCandidates $+              throwError $ GMECabalCompAssignment mdlcs++            let cn = pickComponent candidates+            return $ gmcGhcOpts $ fromJustNote "targetGhcOptions" $ Map.lookup cn mcs++resolvedComponentsCache :: IOish m => FilePath ->+    Cached (GhcModT m) GhcModState+    [GmComponent 'GMCRaw (Set.Set ModulePath)]+    (Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath)))+resolvedComponentsCache distdir = Cached {+    cacheLens = Just (lGmcResolvedComponents . lGmCaches),+    cacheFile = resolvedComponentsCacheFile distdir,+    cachedAction = \tcfs comps ma -> do+        Cradle {..} <- cradle+        let iifs = invalidatingInputFiles tcfs++            setupChanged =+                (cradleRootDir </> setupConfigPath distdir) `elem` iifs++            mums :: Maybe [Either FilePath ModuleName]+            mums =+              let+                  filterOutSetupCfg =+                      filter (/= cradleRootDir </> setupConfigPath distdir)+                  changedFiles = filterOutSetupCfg iifs+              in if null changedFiles || setupChanged+                   then Nothing+                   else Just $ map Left changedFiles++        let mdesc (Left f) = "file:" ++ f+            mdesc (Right mn) = "module:" ++ moduleNameString mn++            changed = map (text . mdesc) $ Foldable.concat mums+            changedDoc | [] <- changed = text "none"+                       | otherwise = sep changed++        gmLog GmDebug "resolvedComponentsCache" $+              text "files changed" <+>: changedDoc++        mcs <- resolveGmComponents ((,) <$> mums <*> ma) comps++        return (setupConfigPath distdir : flatten mcs , mcs)+ }++ where+   flatten :: Map.Map ChComponentName (GmComponent t (Set.Set ModulePath))+           -> [FilePath]+   flatten = Map.elems+      >>> map (gmcHomeModuleGraph >>> gmgGraph+               >>> (Map.keysSet &&& Map.elems)+               >>> uncurry insert+               >>> map (Set.map mpPath)+               >>> Set.unions+              )+      >>> Set.unions+      >>> Set.toList++moduleComponents :: Map ChComponentName (GmComponent t (Set ModulePath))+                 -> Either FilePath ModuleName+                 -> Set ChComponentName+moduleComponents m efnmn =+    foldr' Set.empty m $ \c s ->+        let+            memb =+              case efnmn of+                Left fn  -> fn `Set.member` Set.map mpPath (smp c)+                Right mn -> mn `Set.member` Set.map mpModule (smp c)+        in if memb+           then Set.insert (gmcName c) s+           else s+ where+   smp c = Map.keysSet $ gmgGraph $ gmcHomeModuleGraph c++   foldr' b as f = Map.foldr f b as+++findCandidates :: [Set ChComponentName] -> Set ChComponentName+findCandidates [] = Set.empty+findCandidates scns = foldl1 Set.intersection scns++pickComponent :: Set ChComponentName -> ChComponentName+pickComponent scn = Set.findMin scn++packageGhcOptions :: (IOish m, Applicative m, Gm m) => m [GHCOption]+packageGhcOptions = do+    crdl <- cradle+    case cradleProject crdl of+      proj+          | isCabalHelperProject proj -> getGhcMergedPkgOptions+          | otherwise -> sandboxOpts crdl++-- also works for plain projects!+sandboxOpts :: (IOish m, GmEnv m) => Cradle -> m [String]+sandboxOpts crdl = do+    mCusPkgDb <- getCustomPkgDbStack+    pkgDbStack <- liftIO $ getSandboxPackageDbStack+    let pkgOpts = ghcDbStackOpts $ fromMaybe pkgDbStack mCusPkgDb+    return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts ++ ["-Wall"]+  where+    (wdir, rdir) = (cradleCurrentDir crdl, cradleRootDir crdl)++    getSandboxPackageDbStack :: IO [GhcPkgDb]+    getSandboxPackageDbStack =+        ([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb crdl++resolveGmComponent :: (IOish m, Gm m)+    => Maybe [CompilationUnit] -- ^ Updated modules+    -> GmComponent 'GMCRaw (Set ModulePath)+    -> m (GmComponent 'GMCResolved (Set ModulePath))+resolveGmComponent mums c@GmComponent {..} = do+  distDir <- cradleDistDir <$> cradle+  gmLog GmDebug "resolveGmComponent" $ text $ show $ ghcOpts distDir+  withLightHscEnv (ghcOpts distDir) $ \env -> do+    let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs+    let mg = gmcHomeModuleGraph+    let simp = gmcEntrypoints+    sump <- case mums of+        Nothing -> return simp+        Just ums ->+            Set.fromList . catMaybes <$>+               mapM (resolveModule env srcDirs) ums++    mg' <- canonicalizeModuleGraph =<< updateHomeModuleGraph env mg simp sump++    return $ c { gmcEntrypoints = simp, gmcHomeModuleGraph = mg' }++ where ghcOpts distDir = concat [+           gmcGhcSrcOpts,+           gmcGhcLangOpts,+           [ "-optP-include", "-optP" ++ distDir </> macrosHeaderPath ]+        ]++resolveEntrypoint :: (IOish m, Gm m)+    => Cradle+    -> GmComponent 'GMCRaw ChEntrypoint+    -> m (GmComponent 'GMCRaw (Set ModulePath))+resolveEntrypoint Cradle {..} c@GmComponent {..} = do+    gmLog GmDebug "resolveEntrypoint" $ text $ show $ gmcGhcSrcOpts+    withLightHscEnv gmcGhcSrcOpts $ \env -> do+      let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs+      eps <- liftIO $ resolveChEntrypoints cradleRootDir gmcEntrypoints+      rms <- resolveModule env srcDirs `mapM` eps+      return c { gmcEntrypoints = Set.fromList $ catMaybes rms }++-- TODO: remember that the file from `main-is:` is always module `Main` and let+-- ghc do the warning about it. Right now we run that module through+-- resolveModule like any other+resolveChEntrypoints :: FilePath -> ChEntrypoint -> IO [CompilationUnit]+resolveChEntrypoints _ (ChLibEntrypoint em om) =+    return $ map (Right . chModToMod) (em ++ om)++resolveChEntrypoints _ (ChExeEntrypoint main om) =+    return $ [Left main] ++ map (Right . chModToMod) om++resolveChEntrypoints srcDir ChSetupEntrypoint = do+  shs <- doesFileExist (srcDir </> "Setup.hs")+  slhs <- doesFileExist (srcDir </> "Setup.lhs")+  return $ case (shs, slhs) of+    (True, _) -> [Left "Setup.hs"]+    (_, True) -> [Left "Setup.lhs"]+    (False, False) -> []++chModToMod :: ChModuleName -> ModuleName+chModToMod (ChModuleName mn) = mkModuleName mn+++resolveModule :: (IOish m, Gm m) =>+  HscEnv -> [FilePath] -> CompilationUnit -> m (Maybe ModulePath)+resolveModule env _srcDirs (Right mn) =+    liftIO $ traverse canonicalizeModulePath =<< findModulePath env mn+resolveModule env srcDirs (Left fn') = do+    mfn <-  liftIO $ findFile' srcDirs fn'+    case mfn of+      Nothing -> return Nothing+      Just fn'' -> do+          fn <-  liftIO $ canonicalizePath fn''+          emn <- fileModuleName env fn+          case emn of+              Left errs -> do+                gmLog GmWarning ("resolveModule " ++ show fn) $+                  Pretty.empty $+$ (vcat $ map text errs)+                return Nothing -- TODO: should expose these errors otherwise+                               -- modules with preprocessor/parse errors are+                               -- going to be missing+              Right mmn -> return $ Just $+                  case mmn of+                    Nothing -> mkMainModulePath fn+                    Just mn -> ModulePath mn fn+ where+   -- needed for ghc 7.4+   findFile' dirs file =+       getFirst . mconcat <$> mapM (fmap First . mightExist . (</>file)) dirs++   -- fileModuleName fn (dir:dirs)+   --     | makeRelative dir fn /= fn++type CompilationUnit = Either FilePath ModuleName+type Components =+    [GmComponent 'GMCRaw (Set ModulePath)]+type ResolvedComponentsMap =+    Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath))++resolveGmComponents :: (IOish m, Gm m)+    => Maybe ([CompilationUnit], ResolvedComponentsMap)+        -- ^ Updated modules+    -> Components -> m ResolvedComponentsMap+resolveGmComponents mcache cs = do+    let rcm = fromMaybe Map.empty $ snd <$> mcache++    m' <- foldrM' rcm cs $ \c m -> do+        case Map.lookup (gmcName c) m of+          Nothing -> insertUpdated m c+          Just c' -> if same gmcRawEntrypoints c c' && same gmcGhcSrcOpts c c'+                       then return m+                       else insertUpdated m c+    return m'++ where+   foldrM' b fa f = foldrM f b fa+   insertUpdated m c = do+     rc <- resolveGmComponent (fst <$> mcache) c+     return $ Map.insert (gmcName rc) rc m++   same :: Eq b+        => (forall t a. GmComponent t a -> b)+        -> GmComponent u c -> GmComponent v d -> Bool+   same f a b = (f a) == (f b)++-- | Set the files as targets and load them.+loadTargets :: IOish m => [GHCOption] -> [FilePath] -> GmlT m ()+loadTargets opts targetStrs = do+    targets' <-+        withLightHscEnv opts $ \env ->+                liftM (nubBy ((==) `on` targetId))+                  (mapM ((`guessTarget` Nothing) >=> mapFile env) targetStrs)+              >>= mapM relativize++    let targets = map (\t -> t { targetAllowObjCode = False }) targets'++    gmLog GmDebug "loadTargets" $+          text "Loading" <+>: fsep (map (text . showTargetId) targets)++    setTargets targets++    mg <- depanal [] False++    let interp = needsHscInterpreted mg+    target <- hscTarget <$> getSessionDynFlags+    when (interp && target /= HscInterpreted) $ do+      _ <- setSessionDynFlags . setHscInterpreted =<< getSessionDynFlags+      gmLog GmInfo "loadTargets" $ text "Target needs interpeter, switching to LinkInMemory/HscInterpreted. Perfectly normal if anything is using TemplateHaskell, QuasiQuotes or PatternSynonyms."++    target' <- hscTarget <$> getSessionDynFlags++    case target' of+      HscNothing -> do+        void $ load LoadAllTargets+        forM_ mg $+          handleSourceError (gmLog GmDebug "loadTargets" . text . show)+          . void . (parseModule >=> typecheckModule >=> desugarModule)+      HscInterpreted -> do+        void $ load LoadAllTargets+      _ -> error ("loadTargets: unsupported hscTarget")++    gmLog GmDebug "loadTargets" $ text "Loading done"++  where+    relativize (Target (TargetFile filePath phase) taoc src) = do+      crdl <- cradle+      let tid = TargetFile relativeFilePath phase+          relativeFilePath = makeRelative (cradleRootDir crdl) filePath+      return $ Target tid taoc src+    relativize tgt = return tgt++    showTargetId (Target (TargetModule s) _ _) = moduleNameString s+    showTargetId (Target (TargetFile s _) _ _) = s++needsHscInterpreted :: ModuleGraph -> Bool+needsHscInterpreted = any $ \ms ->+                let df = ms_hspp_opts ms in+#if __GLASGOW_HASKELL__ >= 800+                   TemplateHaskell `xopt` df+                || QuasiQuotes     `xopt` df+                || PatternSynonyms `xopt` df+#else+                   Opt_TemplateHaskell `xopt` df+                || Opt_QuasiQuotes     `xopt` df+#if __GLASGOW_HASKELL__ >= 708+                || (Opt_PatternSynonyms `xopt` df)+#endif+#endif++cabalResolvedComponents :: (IOish m) =>+   GhcModT m (Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath)))+cabalResolvedComponents = do+    crdl@(Cradle{..}) <- cradle+    comps <- mapM (resolveEntrypoint crdl) =<< getComponents+    withAutogen $+      cached cradleRootDir (resolvedComponentsCache cradleDistDir) comps
+ core/GhcMod/Types.hs view
@@ -0,0 +1,406 @@+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, RankNTypes,+  StandaloneDeriving, DefaultSignatures, FlexibleInstances, TemplateHaskell,+  GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}+module GhcMod.Types (+    module GhcMod.Types+  , ModuleName+  , mkModuleName+  , moduleNameString+  ) where++import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Monad.Error (Error(..))+import qualified Control.Monad.IO.Class as MTL+import Control.Exception (Exception)+import Control.Applicative+import Control.Concurrent+import Control.Monad+import Control.DeepSeq+import Data.Binary+import Data.Binary.Generic+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Monoid+import Data.Maybe+import Data.Typeable (Typeable)+import Data.IORef+import Data.Label.Derive+import Distribution.Helper hiding (Programs(..))+import qualified Distribution.Helper as CabalHelper+import Exception (ExceptionMonad)+#if __GLASGOW_HASKELL__ < 708+import qualified MonadUtils as GHC (MonadIO(..))+#endif+import GHC (ModuleName, moduleNameString, mkModuleName)+import HscTypes (HscEnv)+import GHC.Generics+import Pretty (Doc)+import Prelude++import GhcMod.Caching.Types++-- | A constraint alias (-XConstraintKinds) to make functions dealing with+-- 'GhcModT' somewhat cleaner.+--+-- Basicially an @IOish m => m@ is a 'Monad' supporting arbitrary 'IO' and+-- exception handling. Usually this will simply be 'IO' but we parametrise it in+-- the exported API so users have the option to use a custom inner monad.+type IOish m = (Functor m, MonadIO m, MonadBaseControl IO m, ExceptionMonad m)+++-- MonadUtils of GHC 7.6 or earlier defines its own MonadIO.+-- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class.+#if __GLASGOW_HASKELL__ < 708+type MonadIOC m = (GHC.MonadIO m, MTL.MonadIO m)+#else+type MonadIOC m = (MTL.MonadIO m)+#endif++class MonadIOC m => MonadIO m where+  liftIO :: IO a -> m a++-- | Output style.+data OutputStyle = LispStyle  -- ^ S expression style.+                 | PlainStyle -- ^ Plain textstyle.+                   deriving (Show)++-- | The type for line separator. Historically, a Null string is used.+newtype LineSeparator = LineSeparator String deriving (Show)++data FileMapping =  FileMapping {fmPath :: FilePath, fmTemp :: Bool}+                  deriving (Eq, Show)++type FileMappingMap = Map FilePath FileMapping++data ProgramSource = ProgramSourceUser | ProgramSourceStack++data Programs = Programs {+  -- | @ghc@ program name.+    ghcProgram    :: FilePath+  -- | @ghc-pkg@ program name.+  , ghcPkgProgram :: FilePath+  -- | @cabal@ program name.+  , cabalProgram  :: FilePath+  -- | @stack@ program name.+  , stackProgram   :: FilePath+  } deriving (Show)++data OutputOpts = OutputOpts {+  -- | Verbosity+    ooptLogLevel      :: GmLogLevel+  , ooptStyle         :: OutputStyle+  -- | Line separator string.+  , ooptLineSeparator :: LineSeparator+  -- | Stdout/err line multiplexing using prefix encoding. @fst@ is stdout,+  -- @snd@ is stderr prefix.+  , ooptLinePrefix    :: Maybe (String, String)+  } deriving (Show)++data Options = Options {+    optOutput         :: OutputOpts+  , optPrograms       :: Programs+    -- | GHC command line options set on the @ghc-mod@ command line+  , optGhcUserOptions :: [GHCOption]+  , optFileMappings   :: [(FilePath, Maybe FilePath)]+  , optEncoding       :: String+  , optStackBuildDeps :: Bool+  } deriving (Show)++-- | A default 'Options'.+defaultOptions :: Options+defaultOptions = Options {+    optOutput     = OutputOpts {+      ooptLogLevel       = GmWarning+    , ooptStyle          = PlainStyle+    , ooptLineSeparator  = LineSeparator "\0"+    , ooptLinePrefix     = Nothing+    }+  , optPrograms       = Programs {+      ghcProgram     = "ghc"+    , ghcPkgProgram  = "ghc-pkg"+    , cabalProgram   = "cabal"+    , stackProgram   = "stack"+    }+  , optGhcUserOptions = []+  , optFileMappings   = []+  , optEncoding       = "UTF-8"+  , optStackBuildDeps = False+  }++----------------------------------------------------------------++data Project = CabalProject+             | SandboxProject+             | PlainProject+             | StackProject StackEnv+               deriving (Eq, Show, Ord)++isCabalHelperProject :: Project -> Bool+isCabalHelperProject StackProject {} = True+isCabalHelperProject CabalProject {} = True+isCabalHelperProject _ = False++data StackEnv = StackEnv {+      seDistDir       :: FilePath+    , seBinPath       :: [FilePath]+    , seSnapshotPkgDb :: FilePath+    , seLocalPkgDb    :: FilePath+    } deriving (Eq, Show, Ord)++-- | The environment where this library is used.+data Cradle = Cradle {+    cradleProject    :: Project+  -- | The directory where this library is executed.+  , cradleCurrentDir :: FilePath+  -- | The project root directory.+  , cradleRootDir    :: FilePath+  -- | Per-Project temporary directory+  , cradleTempDir    :: FilePath+  -- | The file name of the found cabal file.+  , cradleCabalFile  :: Maybe FilePath+  -- | The build info directory.+  , cradleDistDir    :: FilePath+  } deriving (Eq, Show, Ord)++data GmStream = GmOutStream | GmErrStream+                deriving (Show)++data GhcModEnv = GhcModEnv {+      gmOptions    :: Options+    , gmCradle     :: Cradle+    }++data GhcModOut = GhcModOut {+      gmoOptions :: OutputOpts+    , gmoChan    :: Chan (Either (MVar ()) (GmStream, String))+    }++data GhcModLog = GhcModLog {+      gmLogLevel     :: Maybe GmLogLevel,+      gmLogVomitDump :: Last Bool,+      gmLogMessages  :: [(GmLogLevel, String, Doc)]+    } deriving (Show)++instance Monoid GhcModLog where+    mempty = GhcModLog (Just GmPanic) (Last Nothing) mempty+    GhcModLog ml vd ls `mappend` GhcModLog ml' vd' ls' =+        GhcModLog (ml' `mplus` ml) (vd `mappend` vd') (ls `mappend` ls')++data GmGhcSession = GmGhcSession {+      gmgsSession :: !(IORef HscEnv)+    }++data GhcModCaches = GhcModCaches {+      gmcPackageDbStack   :: CacheContents ChCacheData [GhcPkgDb]+    , gmcMergedPkgOptions :: CacheContents ChCacheData [GHCOption]+    , gmcComponents       :: CacheContents ChCacheData [GmComponent 'GMCRaw ChEntrypoint]+    , gmcResolvedComponents :: CacheContents+          [GmComponent 'GMCRaw (Set.Set ModulePath)]+          (Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath)))+    }++data GhcModState = GhcModState {+      gmGhcSession   :: !(Maybe GmGhcSession)+    , gmCaches       :: !GhcModCaches+    , gmMMappedFiles :: !FileMappingMap+    }++defaultGhcModState :: GhcModState+defaultGhcModState =+    GhcModState n (GhcModCaches n n n n) Map.empty+ where n = Nothing++----------------------------------------------------------------++-- | GHC package database flags.+data GhcPkgDb = GlobalDb+              | UserDb+              | PackageDb String+                deriving (Eq, Show, Generic)++instance Binary GhcPkgDb where+    put = ggput . from+    get = to `fmap` ggget++-- | A single GHC command line option.+type GHCOption = String++-- | An include directory for modules.+type IncludeDir = FilePath++-- | Haskell expression.+newtype Expression = Expression { getExpression :: String }+  deriving (Show, Eq, Ord)++-- | Module name.+newtype ModuleString = ModuleString { getModuleString :: String }+  deriving (Show, Eq, Ord, Binary, NFData)++data GmLogLevel =+    GmSilent+  | GmPanic+  | GmException+  | GmError+  | GmWarning+  | GmInfo+  | GmDebug+  | GmVomit+    deriving (Eq, Ord, Enum, Bounded, Show, Read)++data GmModuleGraph = GmModuleGraph {+    gmgGraph :: Map ModulePath (Set ModulePath)+  } deriving (Eq, Ord, Show, Read, Generic, Typeable)++instance Binary GmModuleGraph where+  put GmModuleGraph {..} = put (mpim, graph)+    where+      mpim :: Map ModulePath Integer+      mpim = Map.fromList $ Map.keys gmgGraph `zip` [0..]+      graph :: Map Integer (Set Integer)+      graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph+      mpToInt :: ModulePath -> Integer+      mpToInt mp = fromJust $ Map.lookup mp mpim++  get = do+    (mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get+    let impm = swapMap mpim+        intToMp i = fromJust $ Map.lookup i impm+        mpGraph :: Map ModulePath (Set ModulePath)+        mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph+    return $ GmModuleGraph mpGraph+    where+      swapMap :: Ord v => Map k v -> Map v k+      swapMap = Map.fromList . map (\(x, y) -> (y, x)) . Map.toList++instance Monoid GmModuleGraph where+  mempty  = GmModuleGraph mempty+  mappend (GmModuleGraph a) (GmModuleGraph a') =+    GmModuleGraph (Map.unionWith Set.union a a')++data GmComponentType = GMCRaw+                     | GMCResolved+data GmComponent (t :: GmComponentType) eps = GmComponent {+    gmcHomeModuleGraph :: GmModuleGraph+  , gmcName            :: ChComponentName+  , gmcGhcOpts         :: [GHCOption]+  , gmcGhcPkgOpts      :: [GHCOption]+  , gmcGhcSrcOpts      :: [GHCOption]+  , gmcGhcLangOpts     :: [GHCOption]+  , gmcRawEntrypoints  :: ChEntrypoint+  , gmcEntrypoints     :: eps+  , gmcSourceDirs      :: [FilePath]+  } deriving (Eq, Ord, Show, Read, Generic, Functor)++instance Binary eps => Binary (GmComponent t eps) where+    put = ggput . from+    get = to `fmap` ggget++data ModulePath = ModulePath { mpModule :: ModuleName, mpPath :: FilePath }+  deriving (Eq, Ord, Show, Read, Generic, Typeable)+instance Binary ModulePath where+    put = ggput . from+    get = to `fmap` ggget++instance Binary ModuleName where+  get = mkModuleName <$> get+  put mn = put (moduleNameString mn)++instance Show ModuleName where+  show mn = "ModuleName " ++ show (moduleNameString mn)++instance Read ModuleName where+  readsPrec d =+    readParen+      (d > app_prec)+      (\r' -> [ (mkModuleName m, t)+              | ("ModuleName", s) <- lex r'+              , (m, t)            <- readsPrec (app_prec + 1) s+              ])+    where+      app_prec = 10++data GhcModError+  = GMENoMsg+  -- ^ Unknown error++  | GMEString String+  -- ^ Some Error with a message. These are produced mostly by+  -- 'fail' calls on GhcModT.++  | GMECabalConfigure GhcModError+  -- ^ Configuring a cabal project failed.++  | GMEStackConfigure GhcModError+  -- ^ Configuring a stack project failed.++  | GMEStackBootstrap GhcModError+    -- ^ Bootstrapping @stack@ environment failed (process exited with failure)++  | GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)]+  -- ^ Could not find a consistent component assignment for modules++  | GMEProcess String String [String] (Either Int GhcModError)+  -- ^ Launching an operating system process failed. Fields in+  -- order: function, command, arguments, (stdout, stderr, exitcode)++  | GMENoCabalFile+  -- ^ No cabal file found.++  | GMETooManyCabalFiles [FilePath]+  -- ^ Too many cabal files found.++    deriving (Eq,Show,Typeable)++instance Error GhcModError where+  noMsg  = GMENoMsg+  strMsg = GMEString++instance Exception GhcModError++instance Binary CabalHelper.Programs where+    put = ggput . from+    get = to `fmap` ggget+instance Binary ChModuleName where+    put = ggput . from+    get = to `fmap` ggget+instance Binary ChComponentName where+    put = ggput . from+    get = to `fmap` ggget+instance Binary ChEntrypoint where+    put = ggput . from+    get = to `fmap` ggget++-- | Options for "lintWith" function+data LintOpts = LintOpts {+        optLintHlintOpts :: [String]+        -- ^ options that will be passed to hlint executable+      } deriving (Show)++-- | Default "LintOpts" instance+defaultLintOpts :: LintOpts+defaultLintOpts = LintOpts []++-- | Options for "browseWith" function+data BrowseOpts = BrowseOpts {+        optBrowseOperators      :: Bool+        -- ^ If 'True', "browseWith" also returns operators.+      , optBrowseDetailed       :: Bool+        -- ^ If 'True', "browseWith" also returns types.+      , optBrowseParents        :: Bool+        -- ^ If 'True', "browseWith" also returns parents.+      , optBrowseQualified      :: Bool+        -- ^ If 'True', "browseWith" will return fully qualified name+    } deriving (Show)++-- | Default "BrowseOpts" instance+defaultBrowseOpts :: BrowseOpts+defaultBrowseOpts = BrowseOpts False False False False++mkLabel ''GhcModCaches+mkLabel ''GhcModState+mkLabel ''Options+mkLabel ''OutputOpts+mkLabel ''Programs
+ core/GhcMod/Utils.hs view
@@ -0,0 +1,165 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP #-}+{-# LANGUAGE DoAndIfThenElse #-}++module GhcMod.Utils (+    module GhcMod.Utils+  , module Utils+  , readProcess+  ) where++import Control.Applicative+import Data.Char+import qualified Data.Map as M+import Data.Maybe (fromMaybe)+import Data.Either (rights)+import Data.List (inits)+import Exception+import GhcMod.Error+import GhcMod.Types+import GhcMod.Monad.Types+import System.Directory+import System.Environment+import System.FilePath+import System.IO.Temp (createTempDirectory)+import System.Process (readProcess)+import Text.Printf++import Paths_ghc_mod (getLibexecDir, getBinDir)+import Utils+import Prelude++-- dropWhileEnd is not provided prior to base 4.5.0.0.+dropWhileEnd :: (a -> Bool) -> [a] -> [a]+dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) []++withDirectory_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a+withDirectory_ dir action =+  gbracket+    (liftIO getCurrentDirectory)+    (liftIO . setCurrentDirectory)+    (\_ -> liftIO (setCurrentDirectory dir) >> action)++uniqTempDirName :: FilePath -> FilePath+uniqTempDirName dir =+  "ghc-mod" ++ map escapeDriveChar drive ++ map escapePathChar path+  where+    (drive, path) = splitDrive dir+    escapeDriveChar :: Char -> Char+    escapeDriveChar c+      | isAlphaNum c = c+      | otherwise     = '-'+    escapePathChar :: Char -> Char+    escapePathChar c+      | c `elem` pathSeparators = '-'+      | otherwise               = c++newTempDir :: FilePath -> IO FilePath+newTempDir _dir =+  flip createTempDirectory "ghc-mod" =<< getTemporaryDirectory++whenM :: Monad m => m Bool -> m () -> m ()+whenM mb ma = mb >>= flip when ma++-- | Returns the path to the currently running ghc-mod executable. With ghc<7.6+-- this is a guess but >=7.6 uses 'getExecutablePath'.+ghcModExecutable :: IO FilePath+ghcModExecutable = do+    exe <- getExecutablePath'+    stack <- lookupEnv "STACK_EXE"+    case takeBaseName exe of+      "spec" | Just _ <- stack ->+          (</> "ghc-mod") <$> getBinDir+      "spec" ->+          (</> "dist/build/ghc-mod/ghc-mod") <$> getCurrentDirectory+      "ghc-mod" ->+          return exe+      _ ->+          return $ takeDirectory exe </> "ghc-mod"++getExecutablePath' :: IO FilePath+#if __GLASGOW_HASKELL__ >= 706+getExecutablePath' = getExecutablePath+#else+getExecutablePath' = getProgName+#endif++canonFilePath :: FilePath -> IO FilePath+canonFilePath f = do+  p <- canonicalizePath f+  e <- doesFileExist p+  when (not e) $ error $ "canonFilePath: not a file: " ++ p+  return p++withMappedFile :: (IOish m, GmState m, GmEnv m) =>+                  forall a. FilePath -> (FilePath -> m a) -> m a+withMappedFile file action = getCanonicalFileNameSafe file >>= lookupMMappedFile >>= runWithFile+  where+    runWithFile (Just to) = action $ fmPath to+    runWithFile _ = action file++getCanonicalFileNameSafe :: (IOish m, GmEnv m) => FilePath -> m FilePath+getCanonicalFileNameSafe fn = do+  let fn' = normalise fn+  pl <- liftIO $ rights <$> (mapM ((try :: IO FilePath -> IO (Either SomeException FilePath)) . canonicalizePath . joinPath) $ reverse $ inits $ splitPath' fn')+  return $+    if (length pl > 0)+    then joinPath $ (head pl):(drop (length pl - 1) (splitPath fn'))+    else error "Current dir doesn't seem to exist?"+  where+#if __GLASGOW_HASKELL__ < 710+    splitPath' = (".":) . splitPath+#else+    splitPath' = splitPath+#endif++mkRevRedirMapFunc :: (Functor m, GmState m, GmEnv m) => m (FilePath -> FilePath)+mkRevRedirMapFunc = do+  rm <- M.fromList <$> map (uncurry mf) <$> M.toList <$> getMMappedFiles+  crdl <- cradle+  return $ \key ->+    fromMaybe key+    $ makeRelative (cradleRootDir crdl)+    <$> M.lookup key rm+  where+    mf :: FilePath -> FileMapping -> (FilePath, FilePath)+    mf from to = (fmPath to, from)++findFilesWith' :: (FilePath -> IO Bool) -> [FilePath] -> String -> IO [FilePath]+findFilesWith' _ [] _ = return []+findFilesWith' f (d:ds) fileName = do+    let file = d </> fileName+    exist <- doesFileExist file+    b <- if exist then f file else return False+    if b then do+               files <- findFilesWith' f ds fileName+               return $ file : files+        else findFilesWith' f ds fileName+++-- Copyright   :  (c) The University of Glasgow 2001+-- | Make a path absolute by prepending the current directory (if it isn't+-- already absolute) and applying 'normalise' to the result.+--+-- If the path is already absolute, the operation never fails.  Otherwise, the+-- operation may fail with the same exceptions as 'getCurrentDirectory'.+makeAbsolute' :: FilePath -> IO FilePath+makeAbsolute' = (normalise <$>) . absolutize+  where absolutize path -- avoid the call to `getCurrentDirectory` if we can+          | isRelative path = (</> path) <$> getCurrentDirectory+          | otherwise       = return path
+ core/GhcMod/World.hs view
@@ -0,0 +1,55 @@+module GhcMod.World where++import GhcMod.GhcPkg+import GhcMod.PathsAndFiles+import GhcMod.Types+import GhcMod.Monad.Types+import GhcMod.Utils++import Control.Applicative+import Data.Maybe+import Data.Traversable hiding (mapM)+import System.FilePath ((</>))++import GHC.Paths (libdir)+import Prelude++data World = World {+    worldPackageCaches :: [TimedFile]+  , worldCabalFile     :: Maybe TimedFile+  , worldCabalConfig   :: Maybe TimedFile+  , worldCabalSandboxConfig :: Maybe TimedFile+  , worldMappedFiles   :: FileMappingMap+  } deriving (Eq)++timedPackageCaches :: IOish m => GhcModT m [TimedFile]+timedPackageCaches = do+    fs <- mapM (liftIO . mightExist) . map (</> packageCache)+            =<< getPackageCachePaths libdir+    (liftIO . timeFile) `mapM` catMaybes fs++getCurrentWorld :: IOish m => GhcModT m World+getCurrentWorld = do+    crdl <- cradle+    pkgCaches    <- timedPackageCaches+    mCabalFile   <- liftIO $ timeFile `traverse` cradleCabalFile crdl+    mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl)+    mCabalSandboxConfig <- liftIO $ timeMaybe (sandboxConfigFile crdl)+    mFileMap     <- getMMappedFiles++    return World {+        worldPackageCaches = pkgCaches+      , worldCabalFile     = mCabalFile+      , worldCabalConfig   = mCabalConfig+      , worldCabalSandboxConfig = mCabalSandboxConfig+      , worldMappedFiles   = mFileMap+      }++didWorldChange :: IOish m => World -> GhcModT m Bool+didWorldChange world = do+    (world /=) <$> getCurrentWorld++isYoungerThanSetupConfig :: FilePath -> World -> IO Bool+isYoungerThanSetupConfig file World {..} = do+  tfile <- timeFile file+  return $ worldCabalConfig < Just tfile
elisp/Makefile view
@@ -1,17 +1,17 @@ SRCS = ghc.el ghc-func.el ghc-doc.el ghc-comp.el ghc-check.el ghc-process.el \        ghc-command.el ghc-info.el ghc-ins-mod.el ghc-indent.el ghc-rewrite.el EMACS = emacs-DETECT = xemacs  TEMPFILE  = temp.el+TEMPFILE2 = temp2.el  all: $(TEMPFILE) ghc.el 	$(EMACS) -batch -q -no-site-file -l ./$(TEMPFILE) -f ghc-compile 	rm -f $(TEMPFILE) -detect: $(TEMPFILE) ghc.el-	$(EMACS) -batch -q -no-site-file -l ./$(TEMPFILE) -f ghc-compile-	rm -f $(DETECT)+lint: $(TEMPFILE2) ghc.el+	$(EMACS) -batch -q -no-site-file -l ./$(TEMPFILE2) -f ghc-compile+	rm -f $(TEMPFILE2)  $(TEMPFILE): 	@echo '(setq load-path (cons "." load-path))' >> $(TEMPFILE)@@ -19,8 +19,15 @@ 	@echo $(SRCS)| sed -e 's/\(ghc[^ ]*\.el\)/"\1"/g' >> $(TEMPFILE) 	@echo ')))' >> $(TEMPFILE) +$(TEMPFILE2):+	@echo '(setq load-path (cons "." load-path))' >> $(TEMPFILE2)+	@echo '(setq hack-local-variables-hook (lambda () (setq lexical-binding t)))' >> $(TEMPFILE2)+	@echo '(defun ghc-compile () (mapcar (lambda (x) (byte-compile-file x)) (list ' >> $(TEMPFILE2)+	@echo $(SRCS)| sed -e 's/\(ghc[^ ]*\.el\)/"\1"/g' >> $(TEMPFILE2)+	@echo ')))' >> $(TEMPFILE2)+ clean:-	rm -f *.elc $(TEMPFILE)+	rm -f *.elc $(TEMPFILE) $(TEMPFILE2)  VERSION = `grep version ghc.el | sed -e 's/[^0-9\.]//g'`
elisp/ghc-check.el view
@@ -20,7 +20,7 @@      :underline (:style wave :color "orangered"))     (t      :inherit error))-  "Face used for marking error lines."+  "Face used for error lines."   :group 'ghc)  (defface ghc-face-warn@@ -28,7 +28,7 @@      :underline (:style wave :color "gold"))     (t      :inherit warning))-  "Face used for marking warning lines."+  "Face used for warning lines."   :group 'ghc)  (defface ghc-face-hole@@ -36,7 +36,7 @@      :underline (:style wave :color "purple"))     (t      :inherit warning))-  "Face used for marking hole lines."+  "Face used for hole lines."   :group 'ghc)  (defvar ghc-check-error-fringe (propertize "!" 'display '(left-fringe exclamation-mark)))@@ -46,27 +46,30 @@ (defvar ghc-check-hole-fringe (propertize "_" 'display '(left-fringe horizontal-bar)))  (defvar ghc-display-error nil-  "*An action to display errors/warnings for 'M-n' and 'M-p:+  "*How to display errors/warnings when using 'M-n' and 'M-p': -nil            does not display errors/warnings.-'minibuffer    displays errors/warnings in the minibuffer.-'other-buffer  displays errors/warnings in the other buffer.+nil            do not display errors/warnings.+'minibuffer    display errors/warnings in the minibuffer.+'other-buffer  display errors/warnings in a new buffer. ")  (defvar ghc-display-hole 'other-buffer-  "*An action to display hole information for 'C-c C-j' and 'C-c C-h'+  "*How to display hole information when using 'C-c C-j' and 'C-c C-h' -'minibuffer    displays errors/warnings in the minibuffer.-'other-buffer  displays errors/warnings in the other buffer"+'minibuffer    display errors/warnings in the minibuffer.+'other-buffer  display errors/warnings in the a new buffer" )  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  (defun ghc-check-syntax ()   (interactive)-  (ghc-with-process (ghc-check-send)-		    'ghc-check-callback-		    (lambda () (setq mode-line-process " -:-"))))+  ;; Only check syntax of visible buffers+  (when (and (buffer-file-name)+	     (file-exists-p (buffer-file-name)))+    (ghc-with-process (ghc-check-send)+		      'ghc-check-callback+		      (lambda () (setq mode-line-process " -:-")))))  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -129,10 +132,10 @@ (defun ghc-to-info (errs)   ;; [^\t] to include \n.   (let ((regex "^\\([^\n]*\\):\\([0-9]+\\):\\([0-9]+\\): *\\([^\t]+\\)")-	info infos)+	infos)     (dolist (err errs (nreverse infos))       (when (string-match regex err)-	(let* ((file (expand-file-name (match-string 1 err))) ;; for Windows+	(let* ((file (expand-file-name (match-string 1 err) ghc-process-root)) ;; for Windows 	       (line (string-to-number (match-string 2 err)))                (coln (string-to-number (match-string 3 err))) 	       (msg (match-string 4 err))@@ -167,18 +170,21 @@ 	  ;; If this is a bottleneck for a large code, let's fix. 	  (goto-char (point-min)) 	  (cond-           ((and (string= ofile file) hole)-            (forward-line (1- line))-            (forward-char (1- coln))-            (setq beg (point))-            (forward-char (length hole))-            (setq end (point)))-	   ((string= ofile file)-	    (forward-line (1- line))-	    (while (eq (char-after) 32) (forward-char))-	    (setq beg (point))-	    (forward-line)-	    (setq end (1- (point))))+	   ((file-equal-p ofile file)+            (if hole+              (progn+                (forward-line (1- line))+                (forward-char (1- coln))+                (setq beg (point))+                (forward-char (length hole))+                (setq end (point)))+              (progn+                (forward-line (1- line))+                (forward-char (1- coln))+                (setq beg (point))+		(forward-sexp)+                ;; (skip-chars-forward "^[:space:]" (line-end-position))+                (setq end (point))))) 	   (t 	    (setq beg (point)) 	    (forward-line)@@ -285,14 +291,13 @@   (let ((file-msgs (ghc-get-only-holes)))     (if (null file-msgs) 	(message "No holes")-      (let ((file (ghc-file-msgs-get-file file-msgs))-	    (msgs (ghc-file-msgs-get-msgs file-msgs)))+      (let ((msgs (ghc-file-msgs-get-msgs file-msgs))) 	(ghc-display 	 nil 	 (lambda ()            (progn 	     (mapc (lambda (x) (insert x "\n\n")) msgs)-             (buttonize-buffer)) ))))))+             (buttonize-buffer))))))))  (defun ghc-display-holes-to-minibuf ()   (let ((file-msgs (ghc-get-only-holes)))@@ -410,6 +415,10 @@ 	  (let ((old (match-string 1 data)) 		(new (match-string 2 data))) 	    (ghc-check-replace old new)))+	 ((string-match "Found hole .\\(_[_[:alnum:]]*\\). with type: \\([^\t\n]+\\)" data)+	  (let ((old (match-string 1 data))+		(new (match-string 2 data)))+	    (ghc-check-replace old new))) 	 (t 	  (setq ret nil))))))) @@ -465,7 +474,7 @@ 	(forward-line) 	(re-search-forward "^$" nil t) 	(insert fn)-	(dotimes (i arity)+	(dotimes (_i arity) 	  (insert " _")) 	(insert  " = error \"" fn "\"\n")))))
elisp/ghc-command.el view
@@ -53,7 +53,7 @@       (let ((inhibit-field-text-motion t))         (sort-subr nil 'forward-line 'end-of-line 		   (lambda ()-		     (re-search-forward "^import\\( *qualified\\)? *" nil t)+		     (re-search-forward "^import +\\(qualified\\)? *" nil t) 		     nil) 		   'end-of-line))       (ghc-merge-lines))))@@ -64,7 +64,7 @@     (while (not (eolp))       ;; qualified modlues are not merged at this moment.       ;; fixme if it is improper.-      (if (looking-at "^import *\\([A-Z][^ \n]+\\) *(\\(.*\\))$")+      (if (looking-at "^import +\\([A-Z][^ \n]+\\) *(\\(.*\\))$") 	  (let ((mod (match-string-no-properties 1)) 		(syms (match-string-no-properties 2)) 		(beg (point)))@@ -73,7 +73,7 @@ 	(forward-line)))))  (defun ghc-merge-line (beg mod syms)-  (let ((regex (concat "^import *" (regexp-quote mod) " *(\\(.*\\))$"))+  (let ((regex (concat "^import +" (regexp-quote mod) " *(\\(.*\\))$")) 	duplicated)     (while (looking-at regex)       (setq duplicated t)
elisp/ghc-comp.el view
@@ -127,7 +127,7 @@   (interactive)   (if (ghc-should-scroll)       (ghc-scroll-completion-buffer)-      (ghc-try-complete)))+    (ghc-try-complete)))  (defun ghc-should-scroll ()   (let ((window (ghc-completion-window)))@@ -265,7 +265,7 @@   (let (ret)     (save-excursion       (goto-char (point-min))-      (while (re-search-forward "^import\\( *qualified\\)? +\\([^\n ]+\\)" nil t)+      (while (re-search-forward "^import +\\(qualified\\)? *\\([^\n ]+\\)" nil t) 	(ghc-add ret (match-string-no-properties 2)) 	(forward-line)))     ret))
elisp/ghc-doc.el view
@@ -10,6 +10,17 @@ (require 'ghc-comp) (require 'ghc-info) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;+;;;+;;; Customize Variables+;;;++(defcustom ghc-doc-browser-function #'browse-url+  "Function used to browse documentation."+  :type '(radio (function-item browse-url)+                (function-item ghc-browse-url-safari))+  :group 'ghc-mod)+ ;;; Code:  (defun ghc-browse-document (&optional haskell-org)@@ -22,40 +33,49 @@       (setq expr (ghc-read-expression expr0))       (setq info (ghc-get-info expr0))       (setq mod (ghc-extact-module-from-info info)))-    (setq pkg-ver-path (ghc-resolve-document-path mod))-    (if (and pkg-ver-path mod)+    (setq pkg-ver-path (and mod (ghc-resolve-document-path mod)))+    (if pkg-ver-path 	(ghc-display-document pkg-ver-path mod haskell-org expr)-      (message "No document found"))))+      (message "No documentation found"))))  (ghc-defstruct pkg-ver-path pkg ver path)  (defun ghc-resolve-document-path (mod)-  (with-temp-buffer-    (ghc-call-process ghc-module-command nil t nil "doc" mod)-    (goto-char (point-min))-    (when (looking-at "^\\([^ ]+\\)-\\([0-9]*\\(\\.[0-9]+\\)*\\) \\(.*\\)$")-      (ghc-make-pkg-ver-path-       :pkg (match-string-no-properties 1)-       :ver (match-string-no-properties 2)-       :path (match-string-no-properties 4)))))+  (let ((root ghc-process-root))+    (with-temp-buffer+      (let ((default-directory root))+	(ghc-call-process ghc-module-command nil t nil "doc" mod))+      (goto-char (point-min))+      (when (looking-at "^\\([^ ]+\\)-\\([0-9]*\\(\\.[0-9]+\\)*\\) \\(.*\\)$")+	(ghc-make-pkg-ver-path+	 :pkg (match-string-no-properties 1)+	 :ver (match-string-no-properties 2)+	 :path (match-string-no-properties 4))))))  (defconst ghc-doc-local-format "file://%s/%s.html") (defconst ghc-doc-hackage-format   "http://hackage.haskell.org/packages/archive/%s/%s/doc/html/%s.html") +(defun ghc-browse-url-safari (uri &rest _args)+"Open a URI in Safari using AppleScript. This preserves anchors."+  (let ((script (format "+tell application \"Safari\"+  open location \"%s\"+  activate+end tell" uri)))+    (do-applescript script)))+ (defun ghc-display-document (pkg-ver-path mod haskell-org &optional symbol)-  (let* ((mod- (ghc-replace-character mod ?. ?-))-	 (pkg  (ghc-pkg-ver-path-get-pkg pkg-ver-path))+  (let* ((pkg  (ghc-pkg-ver-path-get-pkg pkg-ver-path))+         (mod- (ghc-replace-character mod ?. ?-)) 	 (ver  (ghc-pkg-ver-path-get-ver pkg-ver-path)) 	 (path (ghc-pkg-ver-path-get-path pkg-ver-path))-	 (pkg-with-ver (format "%s-%s" pkg ver)) 	 (local (format ghc-doc-local-format path mod-)) 	 (remote (format ghc-doc-hackage-format pkg ver mod-)) 	 (file (format "%s/%s.html" path mod-)) 	 (url0 (if (or haskell-org (not (file-exists-p file))) remote local)) 	 (url (if symbol (ghc-add-anchor url0 symbol) url0)))-    ;; Mac's "open" removes the anchor from "file://", sigh.-    (browse-url url)))+    (funcall ghc-doc-browser-function url)))  (defun ghc-add-anchor (url symbol)   (let ((case-fold-search nil))@@ -75,7 +95,7 @@     (apply 'concat (nreverse acc))))  (defun ghc-extact-module-from-info (info)-  (when (string-match "\`\\([^']+\\)'" info)+  (when (string-match "[`\u2018]\\([^'\u2019]+\\)['\u2019]" info)     (match-string 1 info)))  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;@@ -93,7 +113,7 @@   (read-from-minibuffer "Module name: " def ghc-input-map))  (defun ghc-read-expression (def)-  (read-from-minibuffer "Expression: " def ghc-input-map))+  (read-from-minibuffer "Identifier: " def ghc-input-map))  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
elisp/ghc-func.el view
@@ -18,9 +18,10 @@ (defun ghc-replace-character (string from to)   "Replace characters equal to FROM to TO in STRING."   (let ((ret (copy-sequence string)))-    (dotimes (cnt (length ret) ret)+    (dotimes (cnt (length ret))       (if (char-equal (aref ret cnt) from)-	  (aset ret cnt to)))))+	  (aset ret cnt to)))+    ret))  (defun ghc-replace-character-buffer (from-c to-c)   (let ((from (char-to-string from-c))@@ -66,7 +67,7 @@     (dolist (lst lol)       (dolist (key lst) 	(puthash key key hash)))-    (maphash (lambda (key val) (ghc-add ret key)) hash)+    (maphash (lambda (key _val) (ghc-add ret key)) hash)     ret))  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;@@ -90,8 +91,9 @@     (condition-case nil 	(let ((m (set-marker (make-marker) 1 (current-buffer))) 	      ret)-	  (dotimes (i n (nreverse ret))-	    (ghc-add ret (read m))))+	  (dotimes (_i n)+	    (ghc-add ret (read m)))+	  (nreverse ret))       (error ()))))  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;@@ -108,10 +110,11 @@  (defun ghc-keyword-number-pair (spec)   (let ((len (length spec)) key ret)-    (dotimes (i len (nreverse ret))+    (dotimes (i len)       (setq key (intern (concat ":" (symbol-name (car spec)))))       (setq ret (cons (cons key i) ret))-      (setq spec (cdr spec)))))+      (setq spec (cdr spec)))+    (nreverse ret)))  (defmacro ghc-defstruct (type &rest spec)   `(progn@@ -182,9 +185,19 @@         (funcall ins-func)         (goto-char (point-min))         (if (not fontify)-            (turn-off-haskell-font-lock)+            ;; turn-off-haskell-font-lock has been removed from haskell-mode+            ;; test if the function is defined in our version+            (if (fboundp 'turn-off-haskell-font-lock)+                (turn-off-haskell-font-lock)+              ;; it's not defined, fallback on font-lock-mode+              (font-lock-mode -1))           (haskell-font-lock-defaults-create)-          (turn-on-haskell-font-lock)))+          ;; turn-on-haskell-font-lock has been removed from haskell-mode+          ;; test if the function is defined in our version+          (if (fboundp 'turn-on-haskell-font-lock)+              (turn-on-haskell-font-lock)+            ;; it's not defined, fallback on font-lock-mode+            (turn-on-font-lock))))       (display-buffer buf         '((display-buffer-reuse-window            display-buffer-pop-up-window))))))@@ -194,12 +207,13 @@ (defun ghc-run-ghc-mod (cmds &optional prog)   (let ((target (or prog ghc-module-command)))     (ghc-executable-find target-      (let ((cdir default-directory))+      (let ((cdir (or ghc-process-root  ;; ghc-mod version/debug+		      default-directory))) ;; ghc-mod root 	(with-temp-buffer-	  (cd cdir)-	  (apply 'ghc-call-process target nil t nil-		 (append (ghc-make-ghc-options) cmds))-	  (buffer-substring (point-min) (1- (point-max))))))))+	  (let ((default-directory cdir))+	    (apply 'ghc-call-process target nil '(t nil) nil+		   (append (ghc-make-ghc-options) cmds))+	    (buffer-substring (point-min) (1- (point-max)))))))))  (defmacro ghc-executable-find (cmd &rest body)   ;; (declare (indent 1))
elisp/ghc-indent.el view
@@ -10,11 +10,11 @@  (defvar ghc-indent-offset 4) -(defun ghc-make-indent-shallower (beg end)+(defun ghc-make-indent-shallower (_beg _end)   (interactive "r")   (indent-rigidly (region-beginning) (region-end) (- ghc-indent-offset))) -(defun ghc-make-indent-deeper (beg end)+(defun ghc-make-indent-deeper (_beg _end)   (interactive "r")   (indent-rigidly (region-beginning) (region-end) ghc-indent-offset))
elisp/ghc-info.el view
@@ -63,7 +63,7 @@ 	(cons 'ghc-type-clear-overlay after-change-functions))   (add-hook 'post-command-hook 'ghc-type-post-command-hook)) -(defun ghc-type-clear-overlay (&optional beg end len)+(defun ghc-type-clear-overlay (&optional _beg _end _len)   (when (overlayp ghc-type-overlay)     (ghc-type-set-ix 0)     (ghc-type-set-point 0)@@ -82,7 +82,7 @@     (if (null tinfos) 	(progn 	  (ghc-type-clear-overlay)-	  (message "Cannot guess type"))+	  (message "Cannot determine type"))       (let* ((tinfo (nth (ghc-type-get-ix) tinfos)) 	     (type (ghc-tinfo-get-info tinfo)) 	     (beg-line (ghc-tinfo-get-beg-line tinfo))@@ -111,13 +111,7 @@ 	 (cn (int-to-string (1+ (current-column)))) 	 (file (buffer-file-name)) 	 (cmd (format "type %s %s %s\n" file ln cn)))-    (ghc-sync-process cmd nil 'ghc-type-fix-string)))--(defun ghc-type-fix-string ()-  (save-excursion-    (goto-char (point-min))-    (while (search-forward "[Char]" nil t)-      (replace-match "String"))))+    (ghc-sync-process cmd nil)))  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;@@ -127,7 +121,7 @@ (defun ghc-expand-th ()   (interactive)   (let* ((file (buffer-file-name))-	 (cmds (list "expand" file "-b" "\n"))+	 (cmds (list "-b" "\n" "expand" file)) 	 (source (ghc-run-ghc-mod cmds)))     (when source       (ghc-display
elisp/ghc-ins-mod.el view
@@ -56,7 +56,7 @@  (defun ghc-goto-module-position ()   (goto-char (point-max))-  (if (re-search-backward "^import" nil t)+  (if (re-search-backward "^import +" nil t)       (ghc-goto-empty-line)     (if (not (re-search-backward "^module" nil t)) 	(goto-char (point-min))
elisp/ghc-pkg.el view
@@ -2,4 +2,4 @@   "ghc"   2.0.0   "Sub mode for Haskell mode"-  nil)+  '((haskell-mode "13.0")))
elisp/ghc-process.el view
@@ -1,3 +1,4 @@+;;; -*- lexical-binding: t -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ghc-process.el@@ -10,94 +11,179 @@  (require 'ghc-func) +(defvar ghc-debug-options nil)+;; (setq ghc-debug-options '("-v9"))+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  (defvar ghc-process-running nil)+(defvar ghc-process-file-mapping nil)  (defvar-local ghc-process-process-name nil) (defvar-local ghc-process-original-buffer nil) (defvar-local ghc-process-original-file nil)-(defvar-local ghc-process-callback nil)-(defvar-local ghc-process-hook nil)+(defvar-local ghc-process-root nil) -(defvar ghc-interactive-command "ghc-modi")+(defvar ghc-command "ghc-mod") +(defvar ghc-report-errors t "Report GHC errors to *GHC Error* buffer")+(defvar ghc-error-buffer "*GHC Error*")+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  (defun ghc-get-project-root ()   (ghc-run-ghc-mod '("root"))) -(defun ghc-with-process (cmd callback &optional hook1 hook2)+(defun ghc-with-process (cmd async-after-callback &optional sync-before-hook)   (unless ghc-process-process-name     (setq ghc-process-process-name (ghc-get-project-root)))   (when (and ghc-process-process-name (not ghc-process-running))     (setq ghc-process-running t)-    (if hook1 (funcall hook1))+    (if sync-before-hook (funcall sync-before-hook))     (let* ((cbuf (current-buffer)) 	   (name ghc-process-process-name)-	   (buf (get-buffer-create (concat " ghc-modi:" name)))+	   (root (file-name-as-directory ghc-process-process-name))+	   (buf (get-buffer-create (concat " ghc-mod:" name))) 	   (file (buffer-file-name)) 	   (cpro (get-process name)))+      ;; setting root in the original buffer, sigh+      (setq ghc-process-root root)       (ghc-with-current-buffer buf         (setq ghc-process-original-buffer cbuf) 	(setq ghc-process-original-file file)-	(setq ghc-process-callback callback)-	(setq ghc-process-hook hook2)-	(erase-buffer)-	(let ((pro (ghc-get-process cpro name buf)))-	  (process-send-string pro cmd)+	(setq ghc-process-root root)+	(let ((pro (ghc-get-process cpro name buf root))+	      (map-cmd (format "map-file %s\n" file)))+;	       (unmap-cmd (format "unmap-file %s\n" file)))+	  (when (buffer-modified-p cbuf)+	    (setq ghc-process-file-mapping t)+	    (setq ghc-process-async-after-callback nil)+	    (erase-buffer)+	    (when ghc-debug+	      (ghc-with-debug-buffer+	       (insert (format "%% %s" map-cmd))+	       (insert "CONTENTS + EOT\n")))+	    (process-send-string pro map-cmd)+	    (with-current-buffer cbuf+	      (save-restriction+		(widen)+		(process-send-region pro (point-min) (point-max))))+	    (process-send-string pro "\n\004\n")+	    (condition-case nil+		(let ((inhibit-quit nil))+		  (while ghc-process-file-mapping+		    (accept-process-output pro 0.1 nil t)))+	      (quit+	       (setq ghc-process-running nil)+	       (setq ghc-process-file-mapping nil))))+	  ;; command+	  (setq ghc-process-async-after-callback async-after-callback)+	  (erase-buffer) 	  (when ghc-debug 	    (ghc-with-debug-buffer 	     (insert (format "%% %s" cmd))))+	  (process-send-string pro cmd)++	  ;;; this needs to be done asyncrounously after the command actually+	  ;;; finished, gah+	  ;; (when do-map-file+	  ;;   (when ghc-debug+	  ;;	 (ghc-with-debug-buffer+	  ;;	  (insert (format "%% %s" unmap-cmd))))+	  ;;   (process-send-string pro unmap-cmd))+ 	  pro)))))  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun ghc-get-process (cpro name buf)+(defun ghc-get-process (cpro name buf root)   (cond    ((not cpro)-    (ghc-start-process name buf))+    (ghc-start-process name buf root))    ((not (eq (process-status cpro) 'run))     (delete-process cpro)-    (ghc-start-process name buf))+    (ghc-start-process name buf root))    (t cpro))) -(defun ghc-start-process (name buf)-  (let* ((opts (append '("-b" "\n" "-l") (ghc-make-ghc-options)))-	 (pro (apply 'start-file-process name buf ghc-interactive-command opts)))+(defun ghc-start-process (name buf root)+  (let* ((default-directory root)+	 (process-connection-type nil) ;; using PIPE due to ^D+	 (opts (append ghc-debug-options+		       '("-b" "\n" "-l" "--line-prefix=O: ,E: ")+		       (ghc-make-ghc-options)+		       '("legacy-interactive")))+	 (pro (apply 'start-process name buf ghc-command opts)))     (set-process-filter pro 'ghc-process-filter)     (set-process-sentinel pro 'ghc-process-sentinel)     (set-process-query-on-exit-flag pro nil)     pro))  (defun ghc-process-filter (process string)-  (let ((pbuf (process-buffer process)))+  (let* ((pbuf (process-buffer process))+	 (tbufname (concat " tmp " (buffer-name pbuf)))+	 tbuf)     (if (not (get-buffer pbuf)) 	(setq ghc-process-running nil) ;; just in case-      (ghc-with-current-buffer (process-buffer process)-        (goto-char (point-max))-	(insert string)+      (ghc-with-current-buffer pbuf+	(when ghc-debug+	  (ghc-with-debug-buffer+	   (insert string)))+	(with-current-buffer (get-buffer-create tbufname)+	  (setq tbuf (current-buffer))+	  (goto-char (point-max))+	  (insert string)+	  (goto-char (point-min))+	  (let ((cont t) end out)+	    (while (and cont (not (eobp)) ghc-process-running)+	      (cond+	       ((looking-at "^O: ")+		(setq out t))+	       ((looking-at "^E: ")+		(setq out nil))+	       (t+		(setq cont nil)))+	      (when cont+		(forward-line)+		(unless (bolp) (setq cont nil)))+	      (when cont+		(delete-region 1 4)+		(setq end (point))+		(if out+		    (with-current-buffer pbuf+		      (goto-char (point-max))+		      (insert-buffer-substring tbuf 1 end))+		  (when ghc-report-errors+                    (with-current-buffer (get-buffer-create ghc-error-buffer)+		    (setq buffer-read-only t)+		    (let* ((buffer-read-only nil)+			   (inhibit-read-only t)+			   (cbuf (current-buffer))+			   cwin)+		      (unless (get-buffer-window cbuf) (display-buffer cbuf))+		      (setq cwin (get-buffer-window cbuf))+		      (with-selected-window cwin+			(goto-char (point-max))+			(insert-buffer-substring tbuf 1 end)+			(set-buffer-modified-p nil))+		      (redisplay)))))+		(delete-region 1 end)))))+	(goto-char (point-max)) 	(forward-line -1) 	(cond 	 ((looking-at "^OK$")-	  (if ghc-process-hook (funcall ghc-process-hook))-	  (goto-char (point-min))-	  (funcall ghc-process-callback 'ok)-	  (when ghc-debug-	    (let ((cbuf (current-buffer)))-	      (ghc-with-debug-buffer-	       (insert-buffer-substring cbuf))))-	  (setq ghc-process-running nil))+	  (delete-region (point) (point-max))+	  (setq ghc-process-file-mapping nil)+	  (when ghc-process-async-after-callback+	    (goto-char (point-min))+	    (funcall ghc-process-async-after-callback 'ok)+	    (setq ghc-process-running nil))) 	 ((looking-at "^NG ")-	  (funcall ghc-process-callback 'ng)-	  (when ghc-debug-	    (let ((cbuf (current-buffer)))-	      (ghc-with-debug-buffer-	       (insert-buffer-substring cbuf))))+	  (funcall ghc-process-async-after-callback 'ng) 	  (setq ghc-process-running nil))))))) -(defun ghc-process-sentinel (process event)-  (setq ghc-process-running nil))+(defun ghc-process-sentinel (_process _event)+  (setq ghc-process-running nil)+  (setq ghc-process-file-mapping nil))  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -105,24 +191,23 @@ (defvar ghc-process-num-of-results nil) (defvar ghc-process-results nil) -(defun ghc-sync-process (cmd &optional n hook)+(defun ghc-sync-process (cmd &optional n)   (unless ghc-process-running     (setq ghc-process-rendezvous nil)     (setq ghc-process-results nil)     (setq ghc-process-num-of-results (or n 1))-    (let ((pro (ghc-with-process cmd 'ghc-process-callback nil hook)))+    (let ((pro (ghc-with-process cmd 'ghc-sync-process-callback nil)))+      ;; ghc-process-running is now t.+      ;; But if the process exits abnormally, it is set to nil.       (condition-case nil-	  (while (null ghc-process-rendezvous)-	    ;; 0.01 is too fast for Emacs 24.4.-	    ;; (sit-for 0.1 t) may get stuck when tooltip is displayed.-	    (sit-for 0.1)-	    ;; (discard-input) avoids getting stuck.-	    (discard-input))+	  (let ((inhibit-quit nil))+	    (while (and (null ghc-process-rendezvous) ghc-process-running)+	      (accept-process-output pro 0.1 nil t))) 	(quit 	 (setq ghc-process-running nil))))     ghc-process-results)) -(defun ghc-process-callback (status)+(defun ghc-sync-process-callback (status)   (cond    ((eq status 'ok)     (let* ((n ghc-process-num-of-results)@@ -139,11 +224,12 @@  (defun ghc-kill-process ()   (interactive)-  (let* ((name ghc-process-process-name)-	 (cpro (if name (get-process name))))-    (if (not cpro)-	(message "No process")-      (delete-process cpro)-      (message "A process was killed"))))+  (when (eq major-mode 'haskell-mode)+    (let* ((name ghc-process-process-name)+	   (cpro (if name (get-process name))))+      (if (not cpro)+	  (message "No ghc-mod process")+	(delete-process cpro)+	(message "ghc-mod process was killed")))))  (provide 'ghc-process)
elisp/ghc-rewrite.el view
@@ -125,13 +125,10 @@     (ghc-display nil       (lambda ()         (insert "Possible completions:\n")-        (mapc -          (lambda (x) -            (let* (; (ins1      (insert "- "))-                   (pos-begin (point))-                   (ins       (insert x))-                   (pos-end   (point))-                   (ins3      (insert "\n")))+        (mapc+          (lambda (_x)+            (let ((pos-begin (point))+                  (pos-end   (point)))               (make-button pos-begin pos-end :type 'auto-button)))           (ghc-sinfo-get-info info))))     (select-window (ghc-auto-completion-window))))
elisp/ghc.el view
@@ -28,8 +28,10 @@ 	       (< emacs-minor-version minor)))       (error "ghc-mod requires at least Emacs %d.%d" major minor))) -(defconst ghc-version "5.1.0.2")+(defconst ghc-version "5.8.0.0") +(defgroup ghc-mod '() "ghc-mod customization")+ ;; (eval-when-compile ;;  (require 'haskell-mode)) @@ -115,6 +117,7 @@     (define-key haskell-mode-map ghc-next-hole-key   'ghc-goto-next-hole)     (ghc-comp-init)     (setq ghc-initialized t)+    (add-hook 'kill-buffer-hook 'ghc-kill-process)     (defadvice save-buffer (after ghc-check-syntax-on-save activate)       "Check syntax with GHC when a haskell-mode buffer is saved."       (when (eq 'haskell-mode major-mode) (ghc-check-syntax))))@@ -130,26 +133,26 @@   (let ((el-path (locate-file "ghc.el" load-path)) 	(ghc-path (executable-find "ghc")) ;; FIXME 	(ghc-mod-path (executable-find ghc-module-command))-	(ghc-modi-path (executable-find ghc-interactive-command)) 	(el-ver ghc-version) 	(ghc-ver (ghc-run-ghc-mod '("--version") "ghc")) 	(ghc-mod-ver (ghc-run-ghc-mod '("version")))-	(ghc-modi-ver (ghc-run-ghc-mod '("version") ghc-interactive-command))-	(path (getenv "PATH")))+	(path (getenv "PATH"))+	(debug (ghc-run-ghc-mod '("debug")))) ;; before switching buffers.     (switch-to-buffer (get-buffer-create "**GHC Debug**"))     (erase-buffer)     (insert "Path: check if you are using intended programs.\n")     (insert (format "\t  ghc.el path: %s\n" el-path))     (insert (format "\t ghc-mod path: %s\n" ghc-mod-path))-    (insert (format "\tghc-modi path: %s\n" ghc-modi-path))     (insert (format "\t     ghc path: %s\n" ghc-path))-    (insert "\nVersion: all versions must be the same.\n")+    (insert "\nVersion: all GHC versions must be the same.\n")     (insert (format "\t  ghc.el version %s\n" el-ver))     (insert (format "\t %s\n" ghc-mod-ver))-    (insert (format "\t%s\n" ghc-modi-ver))     (insert (format "\t%s\n" ghc-ver))     (insert "\nEnvironment variables:\n")-    (insert (format "\tPATH=%s\n" path))))+    (insert (format "\tPATH=%s\n" path))+    (insert "\nThe result of \"ghc-mod debug\":\n")+    (insert debug)+    (goto-char (point-min))))  (defun ghc-insert-template-or-signature (&optional flag)   (interactive "P")
ghc-mod.cabal view
@@ -1,162 +1,272 @@ Name:                   ghc-mod-Version:                5.1.0.2-Author:                 Kazu Yamamoto <kazu@iij.ad.jp>-                        Daniel Gröber <dxld@darkboxed.org>-                        Alejandro Serrano <trupill@gmail.com>-Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp>-License:                BSD3+Version:                5.8.0.0+Author:                 Kazu Yamamoto <kazu@iij.ad.jp>,+                        Daniel Gröber <dxld@darkboxed.org>,+                        Alejandro Serrano <trupill@gmail.com>,+                        Nikolay Yakimov <root@livid.pp.ru>+Maintainer:             Daniel Gröber <dxld@darkboxed.org>+License:                AGPL-3 License-File:           LICENSE-Homepage:               http://www.mew.org/~kazu/proj/ghc-mod/-Synopsis:               Happy Haskell Programming-Description:            The ghc-mod command is a backend command to enrich-                        Haskell programming on editors including-                        Emacs, Vim, and Sublime.-                        The ghc-mod command is based on ghc-mod library-                        which is a wrapper of GHC API.-                        This package includes the ghc-mod command,-                        the ghc-mod library, and Emacs front-end-                        (for historical reasons).-                        For more information, please see its home page.+License-Files:          COPYING.BSD3 COPYING.AGPL3+Homepage:               https://github.com/DanielG/ghc-mod+Synopsis:               Happy Haskell Hacking+Description:+  ghc-mod is a backend program to enrich Haskell programming in editors. It+  strives to offer most of the features one has come to expect from modern IDEs+  in any editor. -Category:               Development-Cabal-Version:          >= 1.10-Build-Type:             Simple-Data-Dir:               elisp-Data-Files:             Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el-                        ghc-check.el ghc-process.el ghc-command.el ghc-info.el-                        ghc-ins-mod.el ghc-indent.el ghc-pkg.el ghc-rewrite.el+  ghc-mod provides a library for other haskell programs to use as well as a+  standalone program for easy editor integration. All of the fundamental+  functionality of the frontend program can be accessed through the library+  however many implementation details are hidden and if you want to+  significantly extend ghc-mod you should submit these changes upstream instead+  of implementing them on top of the library.+++Category:               GHC, Development+Cabal-Version:          >= 1.18+Build-Type:             Custom+Data-Files:             elisp/Makefile+                        elisp/*.el Extra-Source-Files:     ChangeLog-			test/data/*.cabal-                        test/data/*.hs-                        test/data/cabal.sandbox.config.in-                        test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf+                        README.md+                        core/GhcMod/Monad/Compat.hs_h+                        test/data/annotations/*.hs                         test/data/broken-cabal/*.cabal-                        test/data/broken-cabal/cabal.sandbox.config.in-                        test/data/broken-sandbox/*.cabal                         test/data/broken-sandbox/cabal.sandbox.config-                        test/data/cabal-flags/*.cabal+                        test/data/broken-sandbox/dummy.cabal+                        test/data/cabal-flags/cabal-flags.cabal+                        test/data/cabal-project/*.cabal+                        test/data/cabal-project/*.hs+                        test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf+                        test/data/cabal-project/subdir1/subdir2/dummy+                        test/data/case-split/*.hs+                        test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf                         test/data/check-test-subdir/*.cabal                         test/data/check-test-subdir/src/Check/Test/*.hs                         test/data/check-test-subdir/test/*.hs                         test/data/check-test-subdir/test/Bar/*.hs-                        test/data/check-packageid/cabal.sandbox.config.in-                        test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf-                        test/data/duplicate-pkgver/cabal.sandbox.config.in                         test/data/duplicate-pkgver/duplicate-pkgver.cabal                         test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-1.0-7c59d13f32294d1ef6dc6233c24df961.conf                         test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-14e543bdae2da4d2aeff5386892c9112.conf                         test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf-                        test/data/pattern-synonyms/*.cabal-                        test/data/pattern-synonyms/*.hs+                        test/data/foreign-export/*.hs                         test/data/ghc-mod-check/*.cabal                         test/data/ghc-mod-check/*.hs-                        test/data/ghc-mod-check/Data/*.hs-                        test/data/subdir1/subdir2/dummy-                        test/data/.cabal-sandbox/packages/00-index.tar+                        test/data/ghc-mod-check/lib/Data/*.hs+                        test/data/hlint/*.hs+                        test/data/home-module-graph/cpp/*.hs+                        test/data/home-module-graph/cycle/*.hs+                        test/data/home-module-graph/errors/*.hs+                        test/data/home-module-graph/indirect/*.hs+                        test/data/home-module-graph/indirect-update/*.hs+                        test/data/import-cycle/*.hs+                        test/data/non-exported/*.hs+                        test/data/pattern-synonyms/*.cabal+                        test/data/pattern-synonyms/*.hs+                        test/data/quasi-quotes/*.hs+                        test/data/template-haskell/*.hs+                        test/data/target/*.hs+                        test/data/check-missing-warnings/*.hs+                        test/data/custom-cradle/custom-cradle.cabal+                        test/data/custom-cradle/ghc-mod.package-db-stack+                        test/data/custom-cradle/package-db-a/.gitkeep+                        test/data/custom-cradle/package-db-b/.gitkeep+                        test/data/custom-cradle/package-db-c/.gitkeep+                        test/data/cabal-preprocessors/*.cabal+                        test/data/cabal-preprocessors/*.hs+                        test/data/cabal-preprocessors/*.hsc+                        test/data/file-mapping/*.hs+                        test/data/file-mapping/preprocessor/*.hs+                        test/data/file-mapping/lhs/*.lhs+                        test/data/nice-qualification/*.hs+                        test/data/stack-project/stack.yaml.in+                        test/data/stack-project/new-template.cabal+                        test/data/stack-project/*.hs+                        test/data/stack-project/app/*.hs+                        test/data/stack-project/src/*.hs+                        test/data/stack-project/test/*.hs+                        bench/data/simple-cabal/simple-cabal.cabal+                        bench/data/simple-cabal/*.hs ++Custom-Setup+  Setup-Depends:         base+                       , Cabal >= 1.18 && < 1.25+                       , containers+                       , filepath+                       , directory+                       , process+                       , template-haskell+                       , transformers++ Library   Default-Language:     Haskell2010-  GHC-Options:          -Wall-  Default-Extensions:   ConstraintKinds, FlexibleContexts-  Exposed-Modules:      Language.Haskell.GhcMod-                        Language.Haskell.GhcMod.Internal-  Other-Modules:        Language.Haskell.GhcMod.Boot-                        Language.Haskell.GhcMod.Browse-                        Language.Haskell.GhcMod.Cabal16-                        Language.Haskell.GhcMod.Cabal18-                        Language.Haskell.GhcMod.Cabal21-                        Language.Haskell.GhcMod.CabalApi-                        Language.Haskell.GhcMod.CabalConfig-                        Language.Haskell.GhcMod.CaseSplit-                        Language.Haskell.GhcMod.Check-                        Language.Haskell.GhcMod.Convert-                        Language.Haskell.GhcMod.Cradle-                        Language.Haskell.GhcMod.Debug-                        Language.Haskell.GhcMod.Doc-                        Language.Haskell.GhcMod.DynFlags-                        Language.Haskell.GhcMod.Error-                        Language.Haskell.GhcMod.FillSig-                        Language.Haskell.GhcMod.Find-                        Language.Haskell.GhcMod.Flag-                        Language.Haskell.GhcMod.GHCApi-                        Language.Haskell.GhcMod.GHCChoice-                        Language.Haskell.GhcMod.Gap-                        Language.Haskell.GhcMod.GhcPkg-                        Language.Haskell.GhcMod.Info-                        Language.Haskell.GhcMod.Lang-                        Language.Haskell.GhcMod.Lint-                        Language.Haskell.GhcMod.Logger-                        Language.Haskell.GhcMod.Monad-                        Language.Haskell.GhcMod.Modules-                        Language.Haskell.GhcMod.PkgDoc-                        Language.Haskell.GhcMod.Read-                        Language.Haskell.GhcMod.SrcUtils-                        Language.Haskell.GhcMod.Target-                        Language.Haskell.GhcMod.Types-                        Language.Haskell.GhcMod.Utils-  Build-Depends:        base >= 4.0 && < 5+  GHC-Options:          -Wall -fno-warn-deprecations+  Default-Extensions:   ScopedTypeVariables, RecordWildCards, NamedFieldPuns,+                        ConstraintKinds, FlexibleContexts,+                        DataKinds, KindSignatures, TypeOperators, ViewPatterns+  HS-Source-Dirs:       ., core, shared+  Exposed-Modules:+                        GhcMod+                        GhcMod.Exe.Boot+                        GhcMod.Exe.Browse+                        GhcMod.Exe.CaseSplit+                        GhcMod.Exe.Check+                        GhcMod.Exe.Debug+                        GhcMod.Exe.FillSig+                        GhcMod.Exe.Find+                        GhcMod.Exe.Flag+                        GhcMod.Exe.Info+                        GhcMod.Exe.Internal+                        GhcMod.Exe.Lang+                        GhcMod.Exe.Lint+                        GhcMod.Exe.Modules+                        GhcMod.Exe.PkgDoc+                        GhcMod.Exe.Test+                        GhcMod.CabalHelper+                        GhcMod.Caching+                        GhcMod.Caching.Types+                        GhcMod.Convert+                        GhcMod.Cradle+                        GhcMod.CustomPackageDb+                        GhcMod.DebugLogger+                        GhcMod.Doc+                        GhcMod.DynFlags+                        GhcMod.DynFlagsTH+                        GhcMod.Error+                        GhcMod.FileMapping+                        GhcMod.Gap+                        GhcMod.GhcPkg+                        GhcMod.HomeModuleGraph+                        GhcMod.LightGhc+                        GhcMod.Logger+                        GhcMod.Logging+                        GhcMod.Monad+                        GhcMod.Monad.Env+                        GhcMod.Monad.Log+                        GhcMod.Monad.Newtypes+                        GhcMod.Monad.Orphans+                        GhcMod.Monad.Out+                        GhcMod.Monad.State+                        GhcMod.Monad.Types+                        GhcMod.Options.DocUtils+                        GhcMod.Options.Help+                        GhcMod.Options.Options+                        GhcMod.Output+                        GhcMod.PathsAndFiles+                        GhcMod.Pretty+                        GhcMod.Read+                        GhcMod.SrcUtils+                        GhcMod.Stack+                        GhcMod.Target+                        GhcMod.Types+                        GhcMod.Utils+                        GhcMod.World+  Other-Modules:        Paths_ghc_mod+                        Utils+                        Data.Binary.Generic+                        System.Directory.ModTime+  Build-Depends:+                      -- See Note [GHC Boot libraries]+                        binary+                      , bytestring                       , containers                       , deepseq                       , directory                       , filepath-                      , ghc-                      , ghc-paths-                      , ghc-syb-utils-                      , hlint >= 1.8.61-                      , io-choice-                      , monad-journal >= 0.4+                      , mtl                       , old-time                       , process-                      , syb+                      , template-haskell                       , time                       , transformers-                      , transformers-base-                      , mtl >= 2.0-                      , monad-control-                      , split-                      , haskell-src-exts-                      , text-                      , djinn-ghc >= 0.0.2.2-  if impl(ghc >= 7.8)-    Build-Depends:      Cabal >= 1.18-  else-    Build-Depends:      convertible-                      , Cabal >= 1.10 && < 1.17-  if impl(ghc <= 7.4.2)-    -- Only used to constrain random to a version that still works with GHC 7.4-    Build-Depends:      random <= 1.0.1.1 +                      , base                 < 4.10 && >= 4.6.0.1+                      , djinn-ghc            < 0.1  && >= 0.0.2.2+                      , extra                < 1.6  && >= 1.4+                      , fclabels             < 2.1  && >= 2.0+                      , ghc-paths            < 0.2  && >= 0.1.0.9+                      , ghc-syb-utils        < 0.3  && >= 0.2.3+                      , haskell-src-exts     < 1.20 && >= 1.18+                      , hlint                < 2.1  && >= 2.0.8+                      , monad-control        < 1.1  && >= 1+                      , monad-journal        < 0.8  && >= 0.4+                      , optparse-applicative < 0.14 && >= 0.13.0.0+                      , pipes                < 4.4  && >= 4.1+                      , safe                 < 0.4  && >= 0.3.9+                      , semigroups           < 0.19 && >= 0.10.0+                      , split                < 0.3  && >= 0.2.2+                      , syb                  < 0.7  && >= 0.5.1+                      , temporary            < 1.3  && >= 1.2.0.3+                      , text                 < 1.3  && >= 1.2.1.3+                      , transformers-base    < 0.5  && >= 0.4.4++                      , cabal-helper         < 0.8  && >= 0.7.3.0+                      , ghc                  < 8.2  && >= 7.6++  if impl(ghc >= 8.0)+    Build-Depends:      ghc-boot+  if impl(ghc < 7.8)+    Build-Depends:      convertible          < 1.2  && >= 1.1.0.0+ Executable ghc-mod   Default-Language:     Haskell2010-  Main-Is:              GHCMod.hs+  Main-Is:              GhcModMain.hs   Other-Modules:        Paths_ghc_mod-  GHC-Options:          -Wall+                      , GhcMod.Exe.Options+                      , GhcMod.Exe.Options.Commands+                      , GhcMod.Exe.Version+                      , GhcMod.Exe.Options.ShellParse+  GHC-Options:          -Wall -fno-warn-deprecations -threaded   Default-Extensions:   ConstraintKinds, FlexibleContexts-  HS-Source-Dirs:       src-  Build-Depends:        base >= 4.0 && < 5-                      , directory+  HS-Source-Dirs:       src, shared+  X-Internal:           True+  Build-Depends:+                      -- See Note [GHC Boot libraries]+                        directory                       , filepath-                      , mtl >= 2.0-                      , ghc+                      , mtl+                      , process++                      , base                 < 4.10 && >= 4.6.0.1+                      , fclabels             < 2.1  && >= 2.0+                      , monad-control        < 1.1  && >= 1+                      , optparse-applicative < 0.14 && >= 0.13.0.0+                      , semigroups           < 0.19 && >= 0.10.0+                      , split                < 0.3  && >= 0.2.2++                      , ghc                  < 8.2  && >= 7.6                       , ghc-mod + Executable ghc-modi   Default-Language:     Haskell2010-  Main-Is:              GHCModi.hs+  Main-Is:              GhcModi.hs   Other-Modules:        Paths_ghc_mod                         Utils-  GHC-Options:          -Wall -threaded+                        System.Directory.ModTime+  GHC-Options:          -Wall -threaded -fno-warn-deprecations+  if os(windows)+      Cpp-Options:      -DWINDOWS   Default-Extensions:   ConstraintKinds, FlexibleContexts-  HS-Source-Dirs:       src-  Build-Depends:        base >= 4.0 && < 5-                      , async-                      , containers+  HS-Source-Dirs:       ., src, shared+  Build-Depends:+                      -- See Note [GHC Boot libraries]+                        binary+                      , deepseq                       , directory                       , filepath-                      , split-                      , ghc+                      , old-time+                      , process+                      , time++                      , base                 < 4.10 && >= 4.6.0.1+                       , ghc-mod + Test-Suite doctest   Type:                 exitcode-stdio-1.0   Default-Language:     Haskell2010@@ -164,62 +274,116 @@   Ghc-Options:          -Wall   Default-Extensions:   ConstraintKinds, FlexibleContexts   Main-Is:              doctests.hs-  Build-Depends:        base-                      , doctest >= 0.9.3+  Build-Depends:        base                 < 4.10 && >= 4.6.0.1+                      , doctest              < 0.12 && >= 0.9.3 + Test-Suite spec   Default-Language:     Haskell2010-  Default-Extensions:   ConstraintKinds, FlexibleContexts+  Default-Extensions:   ScopedTypeVariables, RecordWildCards, NamedFieldPuns,+                        ConstraintKinds, FlexibleContexts,+                        DataKinds, KindSignatures, TypeOperators, ViewPatterns   Main-Is:              Main.hs-  Hs-Source-Dirs:       test, .-  Ghc-Options:          -Wall+  Hs-Source-Dirs:       test, src+  Ghc-Options:          -Wall -fno-warn-deprecations -threaded   Type:                 exitcode-stdio-1.0-  Other-Modules:        Dir-                        Spec+  Other-Modules:        Paths_ghc_mod+                        Dir+                        TestUtils++-- $ ls test/*Spec.hs | sed 's_^.*/\(.*\)\.hs$_\1_' | sort                         BrowseSpec-                        CabalApiSpec+                        CabalHelperSpec+                        CaseSplitSpec                         CheckSpec+                        CradleSpec+                        CustomPackageDbSpec+                        FileMappingSpec+                        FindSpec                         FlagSpec+                        GhcPkgSpec+                        HomeModuleGraphSpec                         InfoSpec                         LangSpec                         LintSpec                         ListSpec                         MonadSpec-                        GhcPkgSpec-                        TestUtils-  Build-Depends:        base >= 4.0 && < 5-                      , containers-                      , deepseq+                        PathsAndFilesSpec+                        ShellParseSpec+                        TargetSpec++  Build-Depends:+                      -- See Note [GHC Boot libraries]+                        containers                       , directory                       , filepath-                      , ghc-                      , ghc-paths-                      , ghc-syb-utils-                      , hlint >= 1.7.1-                      , io-choice-                      , monad-journal >= 0.4-                      , old-time+                      , mtl                       , process-                      , syb-                      , time                       , transformers-                      , transformers-base-                      , mtl >= 2.0-                      , monad-control-                      , hspec >= 1.8.2-                      , split-                      , haskell-src-exts-                      , text-                      , djinn-ghc >= 0.0.2.2-  if impl(ghc >= 7.8)-    Build-Depends:      Cabal >= 1.18-  else-    Build-Depends:      convertible-                      , Cabal >= 1.10 && < 1.17-  if impl(ghc < 7.6)-    Build-Depends:      executable-path-  CPP-Options:        -DSPEC=1 +                      , base                 < 4.10 && >= 4.6.0.1+                      , fclabels             < 2.1  && >= 2.0+                      , hspec                < 2.4  && >= 2.0.0+                      , monad-journal        < 0.8  && >= 0.4+                      , split                < 0.3  && >= 0.2.2+                      , temporary            < 1.3  && >= 1.2.0.3+++  if impl(ghc < 7.8)+    Build-Depends:      convertible          < 1.2  && >= 1.1.0.0+  if impl(ghc >= 8.0)+    Build-Depends:      ghc-boot++  Build-Depends:+                        cabal-helper         < 0.8  && >= 0.7.1.0+                      , ghc                  < 8.2  && >= 7.6+                      , ghc-mod+++Test-Suite shelltest+  Default-Language:     Haskell2010+  Main-Is:              ShellTest.hs+  Hs-Source-Dirs:       shelltest+  Type:                 exitcode-stdio-1.0+  Build-Tools:          shelltest+  Build-Depends:        base                 < 4.10 && >= 4.6.0.1+                      , process              < 1.5+                      -- , shelltestrunner >= 1.3.5+  if !flag(shelltest)+    Buildable: False+++Benchmark criterion+  Type:                 exitcode-stdio-1.0+  Default-Language:     Haskell2010+  Default-Extensions:   ScopedTypeVariables, RecordWildCards, NamedFieldPuns,+                        ConstraintKinds, FlexibleContexts,+                        DataKinds, KindSignatures, TypeOperators, ViewPatterns+  HS-Source-Dirs:       bench, test+  Main-Is:              Bench.hs+  Build-Depends:+                      -- See Note [GHC Boot libraries]+                        directory+                      , filepath++                      , base                 < 4.10 && >= 4.6.0.1+                      , criterion            < 1.2  && >= 1.1.1.0+                      , temporary            < 1.3  && >= 1.2.0.3++                      , ghc-mod+++Flag shelltest+  Description: Enable/disable shelltest test-suite+  Default: False+  Manual:  True++ Source-Repository head   Type:                 git-  Location:             git://github.com/kazu-yamamoto/ghc-mod.git+  Location:             https://github.com/DanielG/ghc-mod.git++-- Note [GHC Boot libraries]+--+-- We don't give bounds to GHC boot libraries as our dependency on 'ghc' already+-- constrains these packages to the version that shipped with GHC.
+ shared/System/Directory/ModTime.hs view
@@ -0,0 +1,63 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.+{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}+module System.Directory.ModTime where++import Control.Applicative+import Control.DeepSeq+import Data.Binary+#if MIN_VERSION_directory(1,2,0)+import Data.Time (UTCTime(..), Day(..), getCurrentTime)+#else+import System.Time (ClockTime(..), getClockTime)+#endif+import System.Directory+import Prelude++#if MIN_VERSION_directory(1,2,0)++newtype ModTime = ModTime UTCTime+    deriving (Eq, Ord, NFData)+getCurrentModTime = ModTime <$> getCurrentTime++instance Binary ModTime where+    put (ModTime (UTCTime (ModifiedJulianDay day) difftime)) =+        put day >> put (toRational difftime)+    get =+        ModTime <$> (UTCTime <$> (ModifiedJulianDay <$> get) <*> (fromRational <$> get))++#else++newtype ModTime = ModTime ClockTime+    deriving (Eq, Ord)+getCurrentModTime = ModTime <$> getClockTime++instance Binary ModTime where+    put (ModTime (TOD s ps)) =+        put s >> put ps+    get =+        ModTime <$> (TOD <$> get <*> get)++instance NFData ModTime where+    rnf (ModTime (TOD s ps)) =+        s `seq` ps `seq` (ModTime $! TOD s ps) `seq` ()++#endif++getCurrentModTime :: IO ModTime++getModTime :: FilePath -> IO ModTime+getModTime f = ModTime <$> getModificationTime f
+ shared/Utils.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE CPP #-}+module Utils where++import Control.Applicative+import Data.Traversable+import System.Directory+import System.Directory.ModTime++import Prelude++data TimedFile = TimedFile { tfPath :: FilePath, tfTime :: ModTime }+                 deriving (Eq)++instance Ord TimedFile where+    compare (TimedFile _ a) (TimedFile _ b) = compare a b++timeFile :: FilePath -> IO TimedFile+timeFile f = TimedFile <$> pure f <*> getModTime f++mightExist :: FilePath -> IO (Maybe FilePath)+mightExist f = do+  exists <- doesFileExist f+  return $ if exists then (Just f) else (Nothing)++timeMaybe :: FilePath -> IO (Maybe TimedFile)+timeMaybe f = traverse timeFile =<< mightExist f
+ shelltest/ShellTest.hs view
@@ -0,0 +1,23 @@+#!/usr/bin/env runhaskell+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2017  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++module Main where++import System.Exit+import System.Process++main = exitWith =<< rawSystem "shelltest" [ "--execdir", "shelltest/" ]
− src/GHCMod.hs 
@@ -1,189 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--module Main where--import Config (cProjectVersion)-import Control.Applicative ((<$>))-import Control.Exception (Exception, Handler(..), ErrorCall(..))-import CoreMonad (liftIO)-import qualified Control.Exception as E-import Data.Typeable (Typeable)-import Data.Version (showVersion)-import Language.Haskell.GhcMod-import Paths_ghc_mod-import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))-import qualified System.Console.GetOpt as O-import System.Directory (doesFileExist)-import System.Environment (getArgs)-import System.Exit (exitFailure)-import System.IO (hPutStr, hPutStrLn, stdout, stderr, hSetEncoding, utf8)--------------------------------------------------------------------progVersion :: String-progVersion = "ghc-mod version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n"--ghcOptHelp :: String-ghcOptHelp = " [-g GHC_opt1 -g GHC_opt2 ...] "--usage :: String-usage =    progVersion-        ++ "Usage:\n"-        ++ "\t ghc-mod list   " ++ ghcOptHelp ++ "[-l] [-d]\n"-        ++ "\t ghc-mod lang    [-l]\n"-        ++ "\t ghc-mod flag    [-l]\n"-        ++ "\t ghc-mod browse " ++ ghcOptHelp ++ "[-l] [-o] [-d] [-q] [<package>:]<module> [[<package>:]<module> ...]\n"-        ++ "\t ghc-mod check  " ++ ghcOptHelp ++ "<HaskellFiles...>\n"-        ++ "\t ghc-mod expand " ++ ghcOptHelp ++ "<HaskellFiles...>\n"-        ++ "\t ghc-mod debug  " ++ ghcOptHelp ++ "\n"-        ++ "\t ghc-mod info   " ++ ghcOptHelp ++ "<HaskellFile> <module> <expression>\n"-        ++ "\t ghc-mod type   " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"-        ++ "\t ghc-mod split  " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"-        ++ "\t ghc-mod sig    " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"-        ++ "\t ghc-mod refine " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no> <expression>\n"-        ++ "\t ghc-mod auto   " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"-        ++ "\t ghc-mod find    <symbol>\n"-        ++ "\t ghc-mod lint    [-h opt] <HaskellFile>\n"-        ++ "\t ghc-mod root\n"-        ++ "\t ghc-mod doc     <module>\n"-        ++ "\t ghc-mod boot\n"-        ++ "\t ghc-mod version\n"-        ++ "\t ghc-mod help\n"-        ++ "\n"-        ++ "<module> for \"info\" and \"type\" is not used, anything is OK.\n"-        ++ "It is necessary to maintain backward compatibility.\n"--------------------------------------------------------------------argspec :: [OptDescr (Options -> Options)]-argspec =-    let option s l udsc dsc = Option s l dsc udsc-        reqArg udsc dsc = ReqArg dsc udsc-    in-      [ option "l" ["tolisp"] "print as a list of Lisp" $-               NoArg $ \o -> o { outputStyle = LispStyle }--      , option "h" ["hlintOpt"] "hlint options" $-               reqArg "hlintOpt" $ \h o -> o { hlintOpts = h : hlintOpts o }--      , option "g" ["ghcOpt"] "GHC options" $-               reqArg "ghcOpt" $ \g o ->-                   o { ghcUserOptions = g : ghcUserOptions o }--      , option "v" ["verbose"] "verbose" $-               NoArg $ \o -> o { ghcUserOptions = "-v" : ghcUserOptions o }--      , option "o" ["operators"] "print operators, too" $-               NoArg $ \o -> o { operators = True }--      , option "d" ["detailed"] "print detailed info" $-               NoArg $ \o -> o { detailed = True }--      , option "q" ["qualified"] "show qualified names" $-               NoArg $ \o -> o { qualified = True }--      , option "b" ["boundary"] "specify line separator (default is Nul string)"$-               reqArg "sep" $ \s o -> o { lineSeparator = LineSeparator s }-  ]--parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String])-parseArgs spec argv-    = case O.getOpt Permute spec argv of-        (o,n,[]  ) -> (foldr id defaultOptions o, n)-        (_,_,errs) -> E.throw (CmdArg errs)--------------------------------------------------------------------data GHCModError = SafeList-                 | ArgumentsMismatch String-                 | NoSuchCommand String-                 | CmdArg [String]-                 | FileNotExist String deriving (Show, Typeable)--instance Exception GHCModError--------------------------------------------------------------------main :: IO ()-main = flip E.catches handlers $ do-    hSetEncoding stdout utf8-    args <- getArgs-    let (opt,cmdArg) = parseArgs argspec args-    let cmdArg0 = cmdArg !. 0-        cmdArg1 = cmdArg !. 1-        cmdArg3 = cmdArg !. 3-        cmdArg4 = cmdArg !. 4-        cmdArg5 = cmdArg !. 5-        remainingArgs = tail cmdArg-        nArgs :: Int -> a -> a-        nArgs n f = if length remainingArgs == n-                        then f-                        else E.throw (ArgumentsMismatch cmdArg0)-    (res, _) <- runGhcModT opt $ case cmdArg0 of-      "list"    -> modules-      "lang"    -> languages-      "flag"    -> flags-      "browse"  -> concat <$> mapM browse remainingArgs-      "check"   -> checkSyntax remainingArgs-      "expand"  -> expandTemplate remainingArgs-      "debug"   -> debugInfo-      "info"    -> nArgs 3 info cmdArg1 cmdArg3-      "type"    -> nArgs 4 $ types cmdArg1 (read cmdArg3) (read cmdArg4)-      "split"   -> nArgs 4 $ splits cmdArg1 (read cmdArg3) (read cmdArg4)-      "sig"     -> nArgs 4 $ sig cmdArg1 (read cmdArg3) (read cmdArg4)-      "refine"  -> nArgs 5 $ refine cmdArg1 (read cmdArg3) (read cmdArg4) cmdArg5-      "auto"    -> nArgs 4 $ auto cmdArg1 (read cmdArg3) (read cmdArg4)-      "find"    -> nArgs 1 $ findSymbol cmdArg1-      "lint"    -> nArgs 1 $ withFile lint cmdArg1-      "root"    -> rootInfo-      "doc"     -> nArgs 1 $ pkgDoc cmdArg1-      "dumpsym" -> dumpSymbol-      "boot"    -> boot-      "version" -> return progVersion-      "help"    -> return $ O.usageInfo usage argspec-      cmd       -> E.throw (NoSuchCommand cmd)--    case res of-      Right s -> putStr s-      Left (GMENoMsg) ->-          hPutStrLn stderr "Unknown error"-      Left (GMEString msg) ->-          hPutStrLn stderr msg-      Left (GMECabalConfigure msg) ->-          hPutStrLn stderr $ "cabal configure failed: " ++ show msg-      Left (GMECabalFlags msg) ->-          hPutStrLn stderr $ "retrieval of the cabal configuration flags failed: " ++ show msg-      Left (GMEProcess cmd msg) ->-          hPutStrLn stderr $-            "launching operating system process `"++c++"` failed: " ++ show msg-          where c = unwords cmd--  where-    handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)]-    handleThenExit handler e = handler e >> exitFailure-    handler1 :: ErrorCall -> IO ()-    handler1 = print -- for debug-    handler2 :: GHCModError -> IO ()-    handler2 SafeList = printUsage-    handler2 (ArgumentsMismatch cmd) = do-        hPutStrLn stderr $ "\"" ++ cmd ++ "\": Arguments did not match"-        printUsage-    handler2 (NoSuchCommand cmd) = do-        hPutStrLn stderr $ "\"" ++ cmd ++ "\" not supported"-        printUsage-    handler2 (CmdArg errs) = do-        mapM_ (hPutStr stderr) errs-        printUsage-    handler2 (FileNotExist file) = do-        hPutStrLn stderr $ "\"" ++ file ++ "\" not found"-        printUsage-    printUsage = hPutStrLn stderr $ '\n' : O.usageInfo usage argspec-    withFile :: IOish m => (FilePath -> GhcModT m a) -> FilePath -> GhcModT m a-    withFile cmd file = do-        exist <- liftIO $ doesFileExist file-        if exist-            then cmd file-            else E.throw (FileNotExist file)-    xs !. idx-      | length xs <= idx = E.throw SafeList-      | otherwise = xs !! idx
− src/GHCModi.hs 
@@ -1,323 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}---- Commands:---  check <file>---  find <symbol>---  info <file> <expr>---  type <file> <line> <column>---  lint [hlint options] <file>---     the format of hlint options is [String] because they may contain---     spaces and also <file> may contain spaces.---  boot---  browse [<package>:]<module>---  quit------ Session separators:---   OK -- success---   NG -- failure--module Main where--import Config (cProjectVersion)-import Control.Applicative ((<$>))-import Control.Concurrent.Async (Async, async, wait)-import Control.Exception (SomeException(..), Exception)-import qualified Control.Exception as E-import Control.Monad (when)-import CoreMonad (liftIO)-import Data.List (find, intercalate)-import Data.List.Split (splitOn)-import Data.Maybe (fromMaybe)-import Data.Set (Set)-import qualified Data.Set as S-import Data.Typeable (Typeable)-import Data.Version (showVersion)-import qualified GHC as G-import Language.Haskell.GhcMod-import Language.Haskell.GhcMod.Internal-import Paths_ghc_mod-import System.Console.GetOpt-import System.Directory (setCurrentDirectory)-import System.Environment (getArgs)-import System.IO (hFlush,stdout)-import System.Exit (ExitCode, exitFailure)--import Utils--------------------------------------------------------------------type Logger = IO String--------------------------------------------------------------------progVersion :: String-progVersion = "ghc-modi version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n"--argspec :: [OptDescr (Options -> Options)]-argspec = [ Option "b" ["boundary"]-            (ReqArg (\s opts -> opts { lineSeparator = LineSeparator s }) "sep")-            "specify line separator (default is Nul string)"-          , Option "l" ["tolisp"]-            (NoArg (\opts -> opts { outputStyle = LispStyle }))-            "print as a list of Lisp"-          , Option "g" []-            (ReqArg (\s opts -> opts { ghcUserOptions = s : ghcUserOptions opts }) "flag") "specify a ghc flag"-          ]--usage :: String-usage =    progVersion-        ++ "Usage:\n"-        ++ "\t ghc-modi [-l] [-b sep] [-g flag]\n"-        ++ "\t ghc-modi version\n"-        ++ "\t ghc-modi help\n"--parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String])-parseArgs spec argv-    = case getOpt Permute spec argv of-        (o,n,[]  ) -> (foldr id defaultOptions o, n)-        (_,_,errs) -> E.throw (CmdArg errs)--------------------------------------------------------------------data GHCModiError = CmdArg [String]-                  deriving (Show, Typeable)--instance Exception GHCModiError---------------------------------------------------------------------- Running two GHC monad threads disables the handling of--- C-c since installSignalHandlers is called twice, sigh.--main :: IO ()-main = E.handle cmdHandler $-    go =<< parseArgs argspec <$> getArgs-  where-    cmdHandler (CmdArg _) = putStr $ usageInfo usage argspec-    go (_,"help":_) = putStr $ usageInfo usage argspec-    go (_,"version":_) = putStr progVersion-    go (opt,_) = flip E.catches handlers $ do-        cradle0 <- findCradle-        let rootdir = cradleRootDir cradle0---            c = cradle0 { cradleCurrentDir = rootdir } TODO: ?????-        setCurrentDirectory rootdir-        symDb <- async $ runGhcModT opt loadSymbolDb-        (res, _) <- runGhcModT opt $ loop S.empty symDb--        case res of-          Right () -> return ()-          Left (GMECabalConfigure msg) -> do-              putStrLn $ notGood $ "cabal configure failed: " ++ show msg-              exitFailure-          Left e -> bug $ show e-      where-        -- this is just in case.-        -- If an error is caught here, it is a bug of GhcMod library.-        handlers = [ E.Handler (\(_ :: ExitCode) -> return ())-                   , E.Handler (\(SomeException e) -> bug $ show e) ]--bug :: String -> IO ()-bug msg = do-  putStrLn $ notGood $ "BUG: " ++ msg-  exitFailure--notGood :: String -> String-notGood msg = "NG " ++ escapeNewlines msg--escapeNewlines :: String -> String-escapeNewlines = replace "\n" "\\n" . replace "\\n" "\\\\n"--replace :: String -> String -> String -> String-replace needle replacement = intercalate replacement . splitOn needle--------------------------------------------------------------------loop :: IOish m => Set FilePath -> SymDbReq -> GhcModT m ()-loop set symDbReq = do-    cmdArg <- liftIO getLine-    let (cmd,arg') = break (== ' ') cmdArg-        arg = dropWhile (== ' ') arg'-    (ret,ok,set') <- case cmd of-        "check"  -> checkStx set arg-        "find"   -> findSym set arg symDbReq-        "lint"   -> lintStx set arg-        "info"   -> showInfo set arg-        "type"   -> showType set arg-        "split"  -> doSplit set arg-        "sig"    -> doSig set arg-        "refine" -> doRefine set arg-        "auto"   -> doAuto set arg-        "boot"   -> bootIt set-        "browse" -> browseIt set arg-        "quit"   -> return ("quit", False, set)-        ""       -> return ("quit", False, set)-        _        -> return ([], True, set)-    if ok then do-        liftIO $ putStr ret-        liftIO $ putStrLn "OK"-      else do-        liftIO $ putStrLn $ notGood ret-    liftIO $ hFlush stdout-    when ok $ loop set' symDbReq--------------------------------------------------------------------checkStx :: IOish m-         => Set FilePath-         -> FilePath-         -> GhcModT m (String, Bool, Set FilePath)-checkStx set file = do-    set' <- newFileSet set file-    let files = S.toList set'-    eret <- check files-    case eret of-        Right ret -> return (ret, True, set')-        Left ret  -> return (ret, True, set) -- fxime: set--newFileSet :: IOish m => Set FilePath -> FilePath -> GhcModT m (Set FilePath)-newFileSet set file = do-    let set1-         | S.member file set = set-         | otherwise         = S.insert file set-    mx <- isSameMainFile file <$> getModSummaryForMain-    return $ case mx of-        Nothing       -> set1-        Just mainfile -> S.delete mainfile set1--getModSummaryForMain :: IOish m => GhcModT m (Maybe G.ModSummary)-getModSummaryForMain = find isMain <$> G.getModuleGraph-  where-    isMain m = G.moduleNameString (G.moduleName (G.ms_mod m)) == "Main"--isSameMainFile :: FilePath -> (Maybe G.ModSummary) -> Maybe FilePath-isSameMainFile _    Nothing  = Nothing-isSameMainFile file (Just x)-    | mainfile == file = Nothing-    | otherwise        = Just mainfile-  where-    mmainfile = G.ml_hs_file (G.ms_location x)-    -- G.ms_hspp_file x is a temporary file with CPP.-    -- this is a just fake.-    mainfile = fromMaybe (G.ms_hspp_file x) mmainfile--------------------------------------------------------------------type SymDbReq = Async (Either GhcModError SymbolDb, GhcModLog)--findSym :: IOish m => Set FilePath -> String -> SymDbReq-        -> GhcModT m (String, Bool, Set FilePath)-findSym set sym dbReq = do-    db <- hoistGhcModT =<< liftIO (wait dbReq)-    ret <- lookupSymbol sym db-    return (ret, True, set)--lintStx :: IOish m => Set FilePath-        -> FilePath-        -> GhcModT m (String, Bool, Set FilePath)-lintStx set optFile = do-    ret <- withOptions changeOpt $ lint file-    return (ret, True, set)-  where-    (opts,file) = parseLintOptions optFile-    hopts = if opts == "" then [] else read opts-    changeOpt o = o { hlintOpts = hopts }---- |--- >>> parseLintOptions "[\"--ignore=Use camelCase\", \"--ignore=Eta reduce\"] file name"--- (["--ignore=Use camelCase", "--ignore=Eta reduce"], "file name")--- >>> parseLintOptions "file name"--- ([], "file name")-parseLintOptions :: String -> (String, String)-parseLintOptions optFile = case brk (== ']') (dropWhile (/= '[') optFile) of-    ("","")      -> ([],   optFile)-    (opt',file') -> (opt', dropWhile (== ' ') file')-  where-    brk _ []         =  ([],[])-    brk p (x:xs')-        | p x        =  ([x],xs')-        | otherwise  =  let (ys,zs) = brk p xs' in (x:ys,zs)--------------------------------------------------------------------showInfo :: IOish m-         => Set FilePath-         -> FilePath-         -> GhcModT m (String, Bool, Set FilePath)-showInfo set fileArg = do-    let [file, expr] = splitN 2 fileArg-    set' <- newFileSet set file-    ret <- info file expr-    return (ret, True, set')--showType :: IOish m-         => Set FilePath-         -> FilePath-         -> GhcModT m (String, Bool, Set FilePath)-showType set fileArg  = do-    let [file, line, column] = splitN 3 fileArg-    set' <- newFileSet set file-    ret <- types file (read line) (read column)-    return (ret, True, set')--doSplit :: IOish m-        => Set FilePath-        -> FilePath-        -> GhcModT m (String, Bool, Set FilePath)-doSplit set fileArg  = do-    let [file, line, column] = splitN 3 fileArg-    set' <- newFileSet set file-    ret <- splits file (read line) (read column)-    return (ret, True, set')--doSig :: IOish m-      => Set FilePath-      -> FilePath-      -> GhcModT m (String, Bool, Set FilePath)-doSig set fileArg  = do-    let [file, line, column] = splitN 3 fileArg-    set' <- newFileSet set file-    ret <- sig file (read line) (read column)-    return (ret, True, set')--doRefine :: IOish m-         => Set FilePath-         -> FilePath-         -> GhcModT m (String, Bool, Set FilePath)-doRefine set fileArg  = do-    let [file, line, column, expr] = splitN 4 fileArg-    set' <- newFileSet set file-    ret <- refine file (read line) (read column) expr-    return (ret, True, set')--doAuto :: IOish m-       => Set FilePath-       -> FilePath-       -> GhcModT m (String, Bool, Set FilePath)-doAuto set fileArg  = do-    let [file, line, column] = splitN 3 fileArg-    set' <- newFileSet set file-    ret <- auto file (read line) (read column)-    return (ret, True, set')--------------------------------------------------------------------bootIt :: IOish m-       => Set FilePath-       -> GhcModT m (String, Bool, Set FilePath)-bootIt set = do-    ret <- boot-    return (ret, True, set)--browseIt :: IOish m-         => Set FilePath-         -> ModuleString-         -> GhcModT m (String, Bool, Set FilePath)-browseIt set mdl = do-    let (det,rest') = break (== ' ') mdl-        rest = dropWhile (== ' ') rest'-    ret <- if det == "-d"-               then withOptions setDetailed (browse rest)-               else browse mdl-    return (ret, True, set)-  where-    setDetailed opt = opt { detailed = True }
+ src/GhcMod/Exe/Options.hs view
@@ -0,0 +1,72 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015  Nikolay Yakimov <root@livid.pp.ru>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}++module GhcMod.Exe.Options (+  parseArgs,+  parseArgsInteractive,+  GhcModCommands(..)+) where++import Options.Applicative+import Options.Applicative.Types++import GhcMod.Exe.Options.Commands+import GhcMod.Exe.Options.ShellParse+import GhcMod.Exe.Version+import GhcMod.Options.DocUtils+import GhcMod.Options.Options+import GhcMod.Types++parseArgs :: IO (Options, GhcModCommands)+parseArgs =+  execParser opts+  where+    opts = info (argAndCmdSpec <**> helpVersion)+           $$  fullDesc+           <=> header "ghc-mod: Happy Haskell Hacking"++parseArgsInteractive :: String -> Either String GhcModCommands+parseArgsInteractive args =+  handle $ execParserPure (prefs idm) opts $ parseCmdLine args+  where+    opts = info interactiveCommandsSpec $$ fullDesc+    handle (Success a) = Right a+    handle (Failure failure) =+          Left $ fst $ renderFailure failure ""+    handle _ = Left "Completion invoked"++helpVersion :: Parser (a -> a)+helpVersion =+      helper+  <*> abortOption (InfoMsg ghcModVersion)+      $$  long "version"+      <=> help "Print the version of the program."+  <*> argument r+      $$  value id+      <=> metavar ""+  where+    r :: ReadM (a -> a)+    r = do+      v <- readerAsk+      case v of+        "help" -> readerAbort ShowHelpText+        "version" -> readerAbort $ InfoMsg ghcModVersion+        _ -> return id++argAndCmdSpec :: Parser (Options, GhcModCommands)+argAndCmdSpec = (,) <$> globalArgSpec <*> commandsSpec
+ src/GhcMod/Exe/Options/Commands.hs view
@@ -0,0 +1,301 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015  Nikolay Yakimov <root@livid.pp.ru>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}++module GhcMod.Exe.Options.Commands where++import Data.Semigroup+import Options.Applicative+import Options.Applicative.Types+import Options.Applicative.Builder.Internal+import GhcMod.Types+import GhcMod.Read+import GhcMod.Options.DocUtils+import GhcMod.Options.Help++type Symbol = String+type Expr = String+type Module = String+type Line = Int+type Col = Int+type Point = (Line, Col)++data GhcModCommands =+    CmdLang+  | CmdFlag+  | CmdDebug+  | CmdBoot+  | CmdNukeCaches+  | CmdRoot+  | CmdLegacyInteractive+  | CmdModules Bool+  | CmdDumpSym+  | CmdFind Symbol+  | CmdDoc Module+  | CmdLint LintOpts FilePath+  | CmdBrowse BrowseOpts [Module]+  | CmdDebugComponent [String]+  | CmdCheck [FilePath]+  | CmdExpand [FilePath]+  | CmdInfo FilePath Symbol+  | CmdType Bool FilePath Point+  | CmdSplit FilePath Point+  | CmdSig FilePath Point+  | CmdAuto FilePath Point+  | CmdRefine FilePath Point Expr+  | CmdTest FilePath+  -- interactive-only commands+  | CmdMapFile FilePath+  | CmdUnmapFile FilePath+  | CmdQuit+  deriving (Show)++commandsSpec :: Parser GhcModCommands+commandsSpec =+  hsubparser commands++commands :: Mod CommandFields GhcModCommands+commands =+       command "lang"+          $$  info (pure CmdLang)+          $$  progDesc "List all known GHC language extensions"+    <> command "flag"+          $$  info (pure CmdFlag)+          $$  progDesc "List GHC -f<foo> flags"+    <> command "debug"+          $$  info (pure CmdDebug)+          $$  progDesc' $$$ do+              "Print debugging information. Please include"+                \\ "the output in any bug reports you submit"+    <> command "debug-component"+          $$  info debugComponentArgSpec+          $$  progDesc' $$$ do+              "Debugging information related to cabal component"+                \\ "resolution"+    <> command "boot"+          $$  info (pure CmdBoot)+          $$  progDesc "Internal command used by the emacs frontend"+    -- <> command "nuke-caches"+    --       $$  info (pure CmdNukeCaches) idm+    <> command "root"+          $$  info (pure CmdRoot)+          $$  progDesc'+              "Try to find the project directory."+          <=> desc $$$ do+              "For Cabal projects this is the"+                \\ "directory containing the cabal file, for projects"+                \\ "that use a cabal sandbox but have no cabal file"+                \\ "this is the directory containing the cabal.sandbox.config"+                \\ "file and otherwise this is the current directory"+    <> command "legacy-interactive"+          $$  info legacyInteractiveArgSpec+          $$  progDesc "ghc-modi compatibility mode"+    <> command "list"+          $$  info modulesArgSpec+          $$  progDesc "List all visible modules"+    <> command "modules"+          $$  info modulesArgSpec+          $$  progDesc "List all visible modules"+    <> command "dumpsym"+          $$  info (pure CmdDumpSym) idm+    <> command "find"+          $$  info findArgSpec+          $$  progDesc "List all modules that define SYMBOL"+    <> command "doc"+          $$  info docArgSpec+          $$  progDesc' $$$ do+              "Try finding the html documentation directory"+                \\ "for the given MODULE"+    <> command "lint"+          $$  info lintArgSpec+          $$  progDesc "Check files using `hlint'"+    <> command "browse"+          $$  info browseArgSpec+          $$  progDesc "List symbols in a module"+    <> command "check"+          $$  info checkArgSpec+          $$  progDesc' $$$ do+              "Load the given files using GHC and report errors/warnings,"+                \\ "but don't produce output files"+    <> command "expand"+          $$  info expandArgSpec+          $$  progDesc "Like `check' but also pass `-ddump-splices' to GHC"+    <> command "info"+          $$  info infoArgSpec+          $$  progDesc' $$$ do+              "Look up an identifier in the context"+                \\ "of FILE (like ghci's `:info')"+    <> command "type"+          $$  info typeArgSpec+          $$  progDesc "Get the type of the expression under (LINE,COL)"+    <> command "split"+          $$  info splitArgSpec+          $$  progDesc+                  "Split a function case by examining a type's constructors"+          <=> desc $$$ do+                "For example given the following code snippet:"+                code $ do+                  "f :: [a] -> a"+                  "f x = _body"+                "would be replaced by:"+                code $ do+                  "f :: [a] -> a"+                  "f [] = _body"+                  "f (x:xs) = _body"+                "(See https://github.com/DanielG/ghc-mod/pull/274)"+    <> command "sig"+          $$  info sigArgSpec+          $$  progDesc "Generate initial code given a signature"+          <=> desc $$$ do+              "For example when (LINE,COL) is on the"+                \\ "signature in the following code snippet:"+              code "func :: [a] -> Maybe b -> (a -> b) -> (a,b)"+              "ghc-mod would add the following on the next line:"+              code "func x y z f = _func_body"+              "(See: https://github.com/DanielG/ghc-mod/pull/274)"+    <> command "auto"+          $$  info autoArgSpec+          $$  progDesc "Try to automatically fill the contents of a hole"+    <> command "refine"+          $$  info refineArgSpec+          $$  progDesc "Refine the typed hole at (LINE,COL) given EXPR"+          <=> desc $$$ do+              "For example if EXPR is `filter', which has type"+                \\ "`(a -> Bool) -> [a] -> [a]' and (LINE,COL) is on"+                \\ " the hole `_body' in the following code snippet:"+              code $ do+                "filterNothing :: [Maybe a] -> [a]"+                "filterNothing xs = _body"+              "ghc-mod changes the code to get a value of type"+                \\ " `[a]', which results in:"+              code "filterNothing xs = filter _body_1 _body_2"+              "(See also: https://github.com/DanielG/ghc-mod/issues/311)"+    <> command "test"+          $$  info (CmdTest <$> strArg "FILE")+          $$  progDesc ""+++interactiveCommandsSpec :: Parser GhcModCommands+interactiveCommandsSpec =+    hsubparser'+        $  commands+        <> command "map-file"+              $$  info mapArgSpec+              $$  progDesc "tells ghc-modi to read `file.hs` source from stdin"+              <=> desc $$$ do+                "Works the same as second form of"+                  \\ "`--map-file` CLI option."+        <> command "unmap-file"+              $$  info unmapArgSpec+              $$  progDesc' $$$ do+                    "unloads previously mapped file,"+                      \\ "so that it's no longer mapped."+              <=> desc $$$ do+                    "`file.hs` can be full path or relative"+                      \\ "to project root, either will work."+        <> command "quit"+              $$ info (pure CmdQuit)+              $$ progDesc "Exit interactive mode"+        <> command ""+              $$ info (pure CmdQuit) idm++strArg :: String -> Parser String+strArg = argument str . metavar++filesArgsSpec :: Parser ([String] -> b) -> Parser b+filesArgsSpec x = x <*> some (strArg "FILES..")++locArgSpec :: Parser (String -> (Int, Int) -> b) -> Parser b+locArgSpec x = x+  <*> strArg "FILE"+  <*> ( (,)+        <$> argument int (metavar "LINE")+        <*> argument int (metavar "COL")+      )++modulesArgSpec, docArgSpec, findArgSpec,+  lintArgSpec, browseArgSpec, checkArgSpec, expandArgSpec,+  infoArgSpec, typeArgSpec, autoArgSpec, splitArgSpec,+  sigArgSpec, refineArgSpec, debugComponentArgSpec,+  mapArgSpec, unmapArgSpec, legacyInteractiveArgSpec :: Parser GhcModCommands++modulesArgSpec = CmdModules+  <$> switch+        $$  long "detailed"+        <=> short 'd'+        <=> help "Print package modules belong to"+findArgSpec = CmdFind <$> strArg "SYMBOL"+docArgSpec = CmdDoc <$> strArg "MODULE"+lintArgSpec = CmdLint+  <$> LintOpts <$$> many $$ strOption+      $$  long "hlintOpt"+      <=> short 'h'+      <=> help "Option to be passed to hlint"+  <*> strArg "FILE"+browseArgSpec = CmdBrowse+  <$> (BrowseOpts+        <$> switch+            $$  long "operators"+            <=> short 'o'+            <=> help "Also print operators"+        <*> switch+            $$  long "detailed"+            <=> short 'd'+            <=> help "Print symbols with accompanying signature"+        <*> switch+            $$  long "parents"+            <=> short 'p'+            <=> help "Print symbols parents"+        <*> switch+            $$  long "qualified"+            <=> short 'q'+            <=> help "Qualify symbols"+      )+  <*> some (strArg "MODULE")+debugComponentArgSpec = filesArgsSpec (pure CmdDebugComponent)+checkArgSpec = filesArgsSpec (pure CmdCheck)+expandArgSpec = filesArgsSpec (pure CmdExpand)+infoArgSpec = CmdInfo+    <$> strArg "FILE"+    <*> strArg "SYMBOL"+typeArgSpec = locArgSpec $ CmdType <$>+        switch+          $$  long "constraints"+          <=> short 'c'+          <=> help "Include constraints into type signature"+autoArgSpec = locArgSpec (pure CmdAuto)+splitArgSpec = locArgSpec (pure CmdSplit)+sigArgSpec = locArgSpec (pure CmdSig)+refineArgSpec = locArgSpec (pure CmdRefine) <*> strArg "SYMBOL"+mapArgSpec = CmdMapFile <$> strArg "FILE"+unmapArgSpec = CmdUnmapFile <$> strArg "FILE"+legacyInteractiveArgSpec = const CmdLegacyInteractive <$>+  optional interactiveCommandsSpec++hsubparser' :: Mod CommandFields a -> Parser a+hsubparser' m = mkParser d g rdr+  where+    Mod _ d g = m `mappend` metavar ""+    (ms, cmds, subs) = mkCommand m+    rdr = CmdReader ms cmds (fmap add_helper . subs)+    add_helper pinfo = pinfo+      { infoParser = infoParser pinfo <**> helper }++int :: ReadM Int+int = do+  v <- readerAsk+  maybe (readerError $ "Not a number \"" ++ v ++ "\"") return $ readMaybe v
+ src/GhcMod/Exe/Options/ShellParse.hs view
@@ -0,0 +1,44 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015  Nikolay Yakimov <root@livid.pp.ru>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.+module GhcMod.Exe.Options.ShellParse (parseCmdLine) where++import Data.Char+import Data.List++go :: String -> String -> [String] -> Bool -> [String]+-- result+go [] curarg accargs _ = reverse $ reverse curarg : accargs+go (c:cl) curarg accargs quotes+  -- open quotes+  | c == '\STX', not quotes+  = go cl curarg accargs True+  -- close quotes+  | c == '\ETX', quotes+  = go cl curarg accargs False+  -- space separates arguments outside quotes+  | isSpace c, not quotes+  = if null curarg+      then go cl curarg accargs quotes+      else go cl [] (reverse curarg : accargs) quotes+  -- general character+  | otherwise = go cl (c:curarg) accargs quotes++parseCmdLine :: String -> [String]+parseCmdLine comline'+  | Just comline <- stripPrefix "ascii-escape " $ dropWhile isSpace comline'+  = go (dropWhile isSpace comline) [] [] False+parseCmdLine [] = [""]+parseCmdLine comline = words comline
+ src/GhcMod/Exe/Version.hs view
@@ -0,0 +1,32 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015  Nikolay Yakimov <root@livid.pp.ru>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++module GhcMod.Exe.Version where++import Paths_ghc_mod+import Data.Version (showVersion)+import Config (cProjectVersion)++progVersion :: String -> String+progVersion pf =+    "ghc-mod"++pf++" version " ++ showVersion version ++ " compiled by GHC "+                               ++ cProjectVersion++ghcModVersion :: String+ghcModVersion = progVersion ""++ghcModiVersion :: String+ghcModiVersion = progVersion "i"
+ src/GhcModMain.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}++module Main where++import Control.Applicative+import Control.Monad+import Data.Typeable (Typeable)+import Data.List+import Data.List.Split+import GhcMod.Pretty+import System.FilePath ((</>))+import System.Directory (setCurrentDirectory, getAppUserDataDirectory,+                        removeDirectoryRecursive)+import System.IO+import System.Exit+import Prelude++import GhcMod+import GhcMod.Exe.Find+import GhcMod.Exe.Options+import GhcMod.Exe.Internal hiding (MonadIO,liftIO)+import GhcMod.Monad+import GhcMod.Types++import Exception++handler :: IOish m => GhcModT m a -> GhcModT m a+handler = flip gcatches+          [ GHandler $ \(e :: ExitCode) -> throw e+          , GHandler $ \(SomeException e) -> exitError $ "ghc-mod: " ++ show e+          ]++main :: IO ()+main =+    parseArgs >>= \res@(globalOptions, _) -> do+      enc <- mkTextEncoding $ optEncoding globalOptions+      hSetEncoding stdout enc+      hSetEncoding stderr enc+      hSetEncoding stdin enc+      catches (progMain res) [+              Handler $ \(e :: GhcModError) ->+                runGmOutT globalOptions $ exitError $ renderGm (gmeDoc e)+            ]++progMain :: (Options, GhcModCommands) -> IO ()+progMain (globalOptions, commands) = runGmOutT globalOptions $+  wrapGhcCommands globalOptions commands++-- ghc-modi+legacyInteractive :: IOish m => GhcModT m ()+legacyInteractive = do+    prepareCabalHelper+    asyncSymbolDb <- newAsyncSymbolDb+    world <- getCurrentWorld+    legacyInteractiveLoop asyncSymbolDb world++legacyInteractiveLoop :: IOish m => AsyncSymbolDb -> World -> GhcModT m ()+legacyInteractiveLoop asyncSymbolDb world = do+    liftIO . setCurrentDirectory =<< cradleRootDir <$> cradle++    -- blocking+    cmdArg <- liftIO getLine++    -- after blocking, we need to see if the world has changed.++    changed <- didWorldChange world++    world' <- if changed+                then getCurrentWorld -- TODO: gah, we're hitting the fs twice+                else return world++    when changed dropSession++    res <- flip gcatches interactiveHandlers $ do+      pargs <- either (throw . InvalidCommandLine . Right) return+              $ parseArgsInteractive cmdArg+      case pargs of+        CmdFind symbol ->+            lookupSymbol symbol =<< getAsyncSymbolDb asyncSymbolDb+        -- other commands are handled here+        x              -> ghcCommands x++    gmPutStr res >> gmPutStrLn "OK" >> liftIO (hFlush stdout)+    legacyInteractiveLoop asyncSymbolDb world'+ where+    interactiveHandlers =+          [ GHandler $ \(e :: ExitCode) -> throw e+          , GHandler $ \(InvalidCommandLine e) -> do+              let err = notGood $ either ("Invalid command line: "++) Prelude.id e+              liftIO $ do+                putStr err+                exitFailure+          , GHandler $ \(SomeException e) -> gmErrStrLn (show e) >> return ""+          ]+    notGood msg = "NG " ++ escapeNewlines msg+    escapeNewlines = replace "\n" "\\n" . replace "\\n" "\\\\n"+    replace needle replacement = intercalate replacement . splitOn needle++getFileSourceFromStdin :: IO String+getFileSourceFromStdin = do+  linesIn <- readStdin'+  return (intercalate "\n" linesIn)+  where+    readStdin' = do+      x <- getLine+      if x/="\EOT"+        then fmap (x:) readStdin'+        else return []++wrapGhcCommands :: (IOish m, GmOut m) => Options -> GhcModCommands -> m ()+wrapGhcCommands opts cmd =+    handleGmError $ runGhcModT opts $ handler $ do+      forM_ (reverse $ optFileMappings opts) $+        uncurry loadMMappedFiles++      gmPutStr =<< ghcCommands cmd+ where+   handleGmError action = do+     (e, _l) <- liftIO . evaluate =<< action+     case e of+       Right _ ->+           return ()+       Left ed ->+           exitError $ renderGm (gmeDoc ed)++   loadMMappedFiles from (Just to) = loadMappedFile from to+   loadMMappedFiles from (Nothing) = do+       src <- liftIO getFileSourceFromStdin+       loadMappedFileSource from src+++ghcCommands :: IOish m => GhcModCommands -> GhcModT m String+-- ghcCommands cmd = action args+ghcCommands (CmdLang) = languages+ghcCommands (CmdFlag) = flags+ghcCommands (CmdDebug) = debugInfo+ghcCommands (CmdDebugComponent ts) = componentInfo ts+ghcCommands (CmdBoot) = boot+-- ghcCommands (CmdNukeCaches) = nukeCaches >> return ""+ghcCommands (CmdRoot) = rootInfo+ghcCommands (CmdLegacyInteractive) = legacyInteractive >> return ""+ghcCommands (CmdModules detail) = modules detail+ghcCommands (CmdDumpSym) = dumpSymbol >> return ""+ghcCommands (CmdFind symb) = findSymbol symb+ghcCommands (CmdDoc m) = pkgDoc m+ghcCommands (CmdLint opts file) = lint opts file+ghcCommands (CmdBrowse opts ms) = concat <$> browse opts `mapM` ms+ghcCommands (CmdCheck files) = checkSyntax files+ghcCommands (CmdExpand files) = expandTemplate files+ghcCommands (CmdInfo file symb) = info file $ Expression symb+ghcCommands (CmdType wCon file (line, col)) = types wCon file line col+ghcCommands (CmdSplit file (line, col)) = splits file line col+ghcCommands (CmdSig file (line, col)) = sig file line col+ghcCommands (CmdAuto file (line, col)) = auto file line col+ghcCommands (CmdRefine file (line, col) expr) = refine file line col $ Expression expr+-- interactive-only commands+ghcCommands (CmdMapFile f) =+      liftIO getFileSourceFromStdin+  >>= loadMappedFileSource f+  >>  return ""+ghcCommands (CmdUnmapFile f) = unloadMappedFile f >> return ""+ghcCommands (CmdQuit) = liftIO exitSuccess+ghcCommands (CmdTest file) = test file+ghcCommands cmd = throw $ InvalidCommandLine $ Left $ show cmd++newtype InvalidCommandLine = InvalidCommandLine (Either String String)+    deriving (Show, Typeable)+instance Exception InvalidCommandLine++exitError :: (MonadIO m, GmOut m) => String -> m a+exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure++nukeCaches :: IOish m => GhcModT m ()+nukeCaches = do+  chdir <- liftIO $ (</> "cabal-helper") <$> getAppUserDataDirectory "ghc-mod"+  c <- cradle++  when (isCabalHelperProject $ cradleProject c) $ do+    let root = cradleRootDir c+    let dist = cradleDistDir c+    liftIO $ (trySome . removeDirectoryRecursive) `mapM_` [chdir, root </> dist]++trySome :: IO a -> IO (Either SomeException a)+trySome = try
+ src/GhcModi.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE ScopedTypeVariables #-}++-- | WARNING+-- This program is deprecated, use `ghc-mod legacy-interactive` instead.++module Main where++import Control.Applicative+import Control.Monad+import Control.Exception+import Data.Version+import Data.Maybe+import System.IO+import System.Exit+import System.Process+import System.FilePath+import System.Environment+import Paths_ghc_mod+import Utils+import Prelude++main :: IO ()+main = do+  hPutStrLn stderr $+    "Warning: ghc-modi is deprecated please use 'ghc-mod legacy-interactive' instead"++  args <- getArgs+  bindir <- getBinDir+  let installedExe = bindir </> "ghc-mod"+  mexe <- mplus <$> mightExist installedExe <*> pathExe+  case mexe of+    Nothing -> do+      hPutStrLn stderr $+        "ghc-modi: Could not find '"++installedExe++"', check your installation!"+      exitWith $ ExitFailure 1++    Just exe -> do+      (_, _, _, h) <-+          createProcess $ proc exe $ ["legacy-interactive"] ++ args+      exitWith =<< waitForProcess h++pathExe :: IO (Maybe String)+pathExe = do+  ev <- try $ words <$> readProcess "ghc-mod" ["--version"] ""+  let mexe = case ev of+               Left (SomeException _) -> Nothing+               Right ["ghc-mod", "version", ver+                     , "compiled", "by", "GHC", _]+                   | showVersion version == ver -> do+                       Just "ghc-mod"+               Right _ -> Nothing++  when (isNothing mexe) $+      hPutStrLn stderr "ghc-modi: ghc-mod executable on PATH has different version, check your installation!"+  return mexe
− src/Utils.hs 
@@ -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
test/BrowseSpec.hs view
@@ -1,8 +1,9 @@ module BrowseSpec where  import Control.Applicative-import Language.Haskell.GhcMod+import GhcMod import Test.Hspec+import Prelude  import TestUtils import Dir@@ -11,22 +12,23 @@ spec = do     describe "browse Data.Map" $ do         it "contains at least `differenceWithKey'" $ do-            syms <- runD $ lines <$> browse "Data.Map"+            syms <- runD $ lines <$> browse defaultBrowseOpts "Data.Map"             syms `shouldContain` ["differenceWithKey"]      describe "browse -d Data.Either" $ do         it "contains functions (e.g. `either') including their type signature" $ do-            syms <- run defaultOptions { detailed = True }-                    $ lines <$> browse "Data.Either"+            syms <- runD+                    $ lines <$> browse defaultBrowseOpts{ optBrowseDetailed = True } "Data.Either"             syms `shouldContain` ["either :: (a -> c) -> (b -> c) -> Either a b -> c"]          it "contains type constructors (e.g. `Left') including their type signature" $ do-            syms <- run defaultOptions { detailed = True}-                    $ lines <$> browse "Data.Either"+            syms <- runD+                    $ lines <$> browse defaultBrowseOpts{ optBrowseDetailed = True } "Data.Either"             syms `shouldContain` ["Left :: a -> Either a b"]      describe "`browse' in a project directory" $ do-        it "lists symbols defined in a a local module (e.g. `Baz.baz)" $ do-            withDirectory_ "test/data" $ do-                syms <- runID $ lines <$> browse "Baz"-                syms `shouldContain` ["baz"]+        it "can list symbols defined in a a local module" $ do+            withDirectory_ "test/data/ghc-mod-check/" $ do+                syms <- runD $ lines <$> browse defaultBrowseOpts "Data.Foo"+                syms `shouldContain` ["foo"]+                syms `shouldContain` ["fibonacci"]
− test/CabalApiSpec.hs 
@@ -1,77 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--module CabalApiSpec where--import Control.Applicative-import Data.Maybe-import Language.Haskell.GhcMod.CabalApi-import Language.Haskell.GhcMod.Cradle-import Language.Haskell.GhcMod.Types-import Test.Hspec-import System.Directory-import System.FilePath-import System.Process (readProcess)--import Dir-import TestUtils--import Config (cProjectVersionInt) -- ghc version--ghcVersion :: Int-ghcVersion = read cProjectVersionInt--spec :: Spec-spec = do-    describe "parseCabalFile" $ do-        it "throws an exception if the cabal file is broken" $ do-            shouldReturnError $ do-              withDirectory_ "test/data/broken-cabal" $ do-                  crdl <- findCradle-                  runD' $ parseCabalFile crdl "broken.cabal"---    describe "getCompilerOptions" $ do-        it "gets necessary CompilerOptions" $ do-            cwd <- getCurrentDirectory-            withDirectory "test/data/subdir1/subdir2" $ \dir -> do-                crdl <- findCradle-                pkgDesc <- runD $ parseCabalFile crdl $ fromJust $ cradleCabalFile crdl-                res <- runD $ getCompilerOptions [] crdl pkgDesc-                let res' = res {-                        ghcOptions  = ghcOptions res-                      , includeDirs = map (toRelativeDir dir) (includeDirs res)-                      }-                if ghcVersion < 706-                  then ghcOptions res' `shouldContain` ["-global-package-conf", "-no-user-package-conf","-package-conf",cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"]-                  else ghcOptions res' `shouldContain` ["-global-package-db", "-no-user-package-db","-package-db",cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"]-                includeDirs res' `shouldBe` ["test/data","test/data/dist/build","test/data/dist/build/autogen","test/data/subdir1/subdir2","test/data/test"]-                (pkgName `map` depPackages res') `shouldContain` ["Cabal"]---    describe "cabalDependPackages" $ do-        it "extracts dependent packages" $ do-            crdl <- findCradle' "test/data/"-            pkgs <- cabalDependPackages . cabalAllBuildInfo <$> runD (parseCabalFile crdl "test/data/cabalapi.cabal")-            pkgs `shouldBe` ["Cabal","base","template-haskell"]-        it "uses non default flags" $ do-            withDirectory_ "test/data/cabal-flags" $ do-                crdl <- findCradle-                _ <- readProcess "cabal" ["configure", "-ftest-flag"] ""-                pkgs <- cabalDependPackages . cabalAllBuildInfo <$> runD (parseCabalFile crdl "cabal-flags.cabal")-                pkgs `shouldBe` ["Cabal","base"]--    describe "cabalSourceDirs" $ do-        it "extracts all hs-source-dirs" $ do-            crdl <- findCradle' "test/data/check-test-subdir"-            dirs <- cabalSourceDirs . cabalAllBuildInfo <$> runD (parseCabalFile crdl "test/data/check-test-subdir/check-test-subdir.cabal")-            dirs `shouldBe` ["src", "test"]-        it "extracts all hs-source-dirs including \".\"" $ do-            crdl <- findCradle' "test/data/"-            dirs <- cabalSourceDirs . cabalAllBuildInfo <$> runD (parseCabalFile crdl "test/data/cabalapi.cabal")-            dirs `shouldBe` [".", "test"]--    describe "cabalAllBuildInfo" $ do-        it "extracts build info" $ do-            crdl <- findCradle' "test/data/"-            info <- cabalAllBuildInfo <$> runD (parseCabalFile crdl "test/data/cabalapi.cabal")-            show info `shouldBe` "[BuildInfo {buildable = True, buildTools = [], cppOptions = [], ccOptions = [], ldOptions = [], pkgconfigDepends = [], frameworks = [], cSources = [], hsSourceDirs = [\".\"], otherModules = [ModuleName [\"Browse\"],ModuleName [\"CabalApi\"],ModuleName [\"Cabal\"],ModuleName [\"CabalDev\"],ModuleName [\"Check\"],ModuleName [\"ErrMsg\"],ModuleName [\"Flag\"],ModuleName [\"GHCApi\"],ModuleName [\"GHCChoice\"],ModuleName [\"Gap\"],ModuleName [\"Info\"],ModuleName [\"Lang\"],ModuleName [\"Lint\"],ModuleName [\"List\"],ModuleName [\"Paths_ghc_mod\"],ModuleName [\"Types\"]], defaultLanguage = Nothing, otherLanguages = [], defaultExtensions = [], otherExtensions = [], oldExtensions = [], extraLibs = [], extraLibDirs = [], includeDirs = [], includes = [], installIncludes = [], options = [(GHC,[\"-Wall\"])], ghcProfOptions = [], ghcSharedOptions = [], customFieldsBI = [], targetBuildDepends = [Dependency (PackageName \"Cabal\") (UnionVersionRanges (ThisVersion (Version {versionBranch = [1,10], versionTags = []})) (LaterVersion (Version {versionBranch = [1,10], versionTags = []}))),Dependency (PackageName \"base\") (IntersectVersionRanges (UnionVersionRanges (ThisVersion (Version {versionBranch = [4,0], versionTags = []})) (LaterVersion (Version {versionBranch = [4,0], versionTags = []}))) (EarlierVersion (Version {versionBranch = [5], versionTags = []}))),Dependency (PackageName \"template-haskell\") AnyVersion]},BuildInfo {buildable = True, buildTools = [], cppOptions = [], ccOptions = [], ldOptions = [], pkgconfigDepends = [], frameworks = [], cSources = [], hsSourceDirs = [\"test\",\".\"], otherModules = [ModuleName [\"Expectation\"],ModuleName [\"BrowseSpec\"],ModuleName [\"CabalApiSpec\"],ModuleName [\"FlagSpec\"],ModuleName [\"LangSpec\"],ModuleName [\"LintSpec\"],ModuleName [\"ListSpec\"]], defaultLanguage = Nothing, otherLanguages = [], defaultExtensions = [], otherExtensions = [], oldExtensions = [], extraLibs = [], extraLibDirs = [], includeDirs = [], includes = [], installIncludes = [], options = [], ghcProfOptions = [], ghcSharedOptions = [], customFieldsBI = [], targetBuildDepends = [Dependency (PackageName \"Cabal\") (UnionVersionRanges (ThisVersion (Version {versionBranch = [1,10], versionTags = []})) (LaterVersion (Version {versionBranch = [1,10], versionTags = []}))),Dependency (PackageName \"base\") (IntersectVersionRanges (UnionVersionRanges (ThisVersion (Version {versionBranch = [4,0], versionTags = []})) (LaterVersion (Version {versionBranch = [4,0], versionTags = []}))) (EarlierVersion (Version {versionBranch = [5], versionTags = []})))]}]"
+ test/CabalHelperSpec.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE CPP #-}+module CabalHelperSpec where++import Control.Arrow+import Control.Applicative+import Distribution.Helper+import GhcMod.CabalHelper+import GhcMod.PathsAndFiles+import GhcMod.Error+import Test.Hspec+import System.Directory+import System.FilePath+import System.Process+import Prelude++import Dir+import TestUtils+import Data.List++import Config (cProjectVersionInt)++ghcVersion :: Int+ghcVersion = read cProjectVersionInt++gmeProcessException :: GhcModError -> Bool+gmeProcessException GMEProcess {} = True+gmeProcessException _ = False++pkgOptions :: [String] -> [String]+pkgOptions [] = []+pkgOptions (_:[]) = []+pkgOptions (x:y:xs) | x == "-package-id" = [name y] ++ pkgOptions xs+                    | otherwise = pkgOptions (y:xs)+ where+   stripDash s = maybe s id $ (flip drop s . (+1) <$> findIndex (=='-') s)+#if __GLASGOW_HASKELL__ >= 800+   name s = reverse $ stripDash $ reverse s+#else+   name s = reverse $ stripDash $ stripDash $ reverse s+#endif++idirOpts :: [(c, [String])] -> [(c, [String])]+idirOpts = map (second $ map (drop 2) . filter ("-i"`isPrefixOf`))++spec :: Spec+spec = do+    describe "getComponents" $ do+        it "throws an exception if the cabal file is broken" $ do+            let tdir = "test/data/broken-cabal"+            runD' tdir getComponents `shouldThrow` anyIOException++        it "handles sandboxes correctly" $ do+            let tdir = "test/data/cabal-project"+            cwd <- getCurrentDirectory++            -- TODO: ChSetupHsName should also have sandbox stuff, see related+            -- comment in cabal-helper+            opts <- map gmcGhcOpts . filter ((/= ChSetupHsName) . gmcName) <$> runD' tdir getComponents++            bp <- buildPlatform readProcess+            if ghcVersion < 706+              then forM_ opts (\o -> o `shouldContain` ["-no-user-package-conf","-package-conf", cwd </> "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir bp])+              else forM_ opts (\o -> o `shouldContain` ["-no-user-package-db","-package-db",cwd </> "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir bp])++#if !MIN_VERSION_ghc(7,8,0)+        it "handles stack project" $ do+            let tdir = "test/data/stack-project"+            [ghcOpts] <- map gmcGhcOpts . filter ((==ChExeName "new-template-exe") . gmcName) <$> runD' tdir getComponents+            let pkgs = pkgOptions ghcOpts+            sort pkgs `shouldBe` ["base", "bytestring"]+#endif++        it "extracts build dependencies" $ do+            let tdir = "test/data/cabal-project"+            opts <- map gmcGhcOpts <$> runD' tdir getComponents+            let ghcOpts:_ = opts+                pkgs = pkgOptions ghcOpts+            pkgs `shouldBe` ["Cabal","base","template-haskell"]++        it "uses non default flags and preserves them across reconfigures" $ do+            let tdir = "test/data/cabal-flags"+            _ <- withDirectory_ tdir $+                readProcess "cabal" ["configure", "-ftest-flag"] ""++            let test = do+                  opts <- map gmcGhcOpts <$> runD' tdir getComponents+                  let ghcOpts = head opts+                      pkgs = pkgOptions ghcOpts+                  pkgs `shouldBe` ["Cabal","base"]++            test++            touch $ tdir </> "cabal-flags.cabal"++            test++touch :: FilePath -> IO ()+touch fn = do+  f <- readFile fn+  writeFile (fn <.> "tmp") f+  renameFile (fn <.> "tmp") fn
+ test/CaseSplitSpec.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE CPP #-}+module CaseSplitSpec where++import GhcMod+import Test.Hspec+import TestUtils+import Dir++main :: IO ()+main = do+  hspec spec++spec :: Spec+spec = do+    describe "case split" $ do+#if __GLASGOW_HASKELL__ >= 708+        it "does not blow up on HsWithBndrs panic" $ do+            withDirectory_ "test/data/case-split" $ do+                res <- runD $ splits "Vect.hs" 24 10+                res `shouldBe` "24 1 24 30"+++                        " \"mlAppend Nil y = _mlAppend_body\NUL"+++                           "mlAppend (Cons x1 x2) y = _mlAppend_body\"\n"++        it "works with case expressions" $ do+            withDirectory_ "test/data/case-split" $ do+                res <- runD $ splits "Vect.hs" 28 20+                res `shouldBe` "28 19 28 39"+++                        " \"Nil -> _mlAppend_body\NUL"+++                        "                  (Cons x'1 x'2) -> _mlAppend_body\"\n"++        it "works with where clauses" $ do+            withDirectory_ "test/data/case-split" $ do+                res <- runD $ splits "Vect.hs" 34 17+                res `shouldBe` "34 5 34 43"+++                        " \"mlReverse' Nil accum = _mlReverse_body\NUL"+++                        "    mlReverse' (Cons xs'1 xs'2) accum = _mlReverse_body\"\n"++        it "works with let bindings" $ do+            withDirectory_ "test/data/case-split" $ do+                res <- runD $ splits "Vect.hs" 38 33+                res `shouldBe` "38 21 38 59"+++                        " \"mlReverse' Nil accum = _mlReverse_body\NUL"+++                        "                    mlReverse' (Cons xs'1 xs'2) accum = _mlReverse_body\"\n"+#else+        it "does not blow up on HsWithBndrs panic" $ do+            withDirectory_ "test/data/case-split" $ do+                res <- runD $ splits "Vect706.hs" 24 10+                res `shouldBe` "24 1 24 25"+++                        " \"mlAppend Nil y = undefined\NUL"+++                           "mlAppend (Cons x1 x2) y = undefined\"\n"++        it "works with case expressions" $ do+            withDirectory_ "test/data/case-split" $ do+                res <- runD $ splits "Vect706.hs" 28 20+                res `shouldBe` "28 19 28 34"+++                        " \"Nil -> undefined\NUL"+++                        "                  (Cons x'1 x'2) -> undefined\"\n"++        it "works with where clauses" $ do+            withDirectory_ "test/data/case-split" $ do+                res <- runD $ splits "Vect706.hs" 34 17+                res `shouldBe` "34 5 34 37"+++                        " \"mlReverse' Nil accum = undefined\NUL"+++                        "    mlReverse' (Cons xs'1 xs'2) accum = undefined\"\n"++        it "works with let bindings" $ do+            withDirectory_ "test/data/case-split" $ do+                res <- runD $ splits "Vect706.hs" 38 33+                res `shouldBe` "38 21 38 53"+++                        " \"mlReverse' Nil accum = undefined\NUL"+++                        "                    mlReverse' (Cons xs'1 xs'2) accum = undefined\"\n"++#endif+        it "doesn't crash when source doesn't make sense" $+            withDirectory_ "test/data/case-split" $ do+                res <- runD $ splits "Crash.hs" 4 6+#if __GLASGOW_HASKELL__ < 710+                res `shouldBe` "4 1 4 19 \"test x = undefined\"\n"+#else+                res `shouldBe` ""+#endif
test/CheckSpec.hs view
@@ -1,9 +1,10 @@ {-# LANGUAGE CPP #-} module CheckSpec where -import Data.List (isSuffixOf, isInfixOf, isPrefixOf)-import Language.Haskell.GhcMod-import System.FilePath+import GhcMod++import Data.List+import System.Process import Test.Hspec  import TestUtils@@ -14,38 +15,66 @@     describe "checkSyntax" $ do         it "works even if an executable depends on the library defined in the same cabal file" $ do             withDirectory_ "test/data/ghc-mod-check" $ do-                res <- runID $ checkSyntax ["main.hs"]+                res <- runD $ checkSyntax ["main.hs"]                 res `shouldBe` "main.hs:5:1:Warning: Top-level binding with no type signature: main :: IO ()\n" +         it "works even if a module imports another module from a different directory" $ do             withDirectory_ "test/data/check-test-subdir" $ do-                res <- runID $ checkSyntax ["test/Bar/Baz.hs"]+                _ <- system "cabal configure --enable-tests"+                res <- runD $ checkSyntax ["test/Bar/Baz.hs"]                 res `shouldSatisfy` (("test" </> "Foo.hs:3:1:Warning: Top-level binding with no type signature: foo :: [Char]\n") `isSuffixOf`)          it "detects cyclic imports" $ do-            withDirectory_ "test/data" $ do-                res <- runID $ checkSyntax ["Mutual1.hs"]+            withDirectory_ "test/data/import-cycle" $ do+                res <- runD $ checkSyntax ["Mutual1.hs"]                 res `shouldSatisfy` ("Module imports form a cycle" `isInfixOf`)          it "works with modules using QuasiQuotes" $ do-            withDirectory_ "test/data" $ do-                res <- runID $ checkSyntax ["Baz.hs"]-                res `shouldSatisfy` ("Baz.hs:5:1:Warning:" `isPrefixOf`)+            withDirectory_ "test/data/quasi-quotes" $ do+                res <- runD $ checkSyntax ["QuasiQuotes.hs"]+                res `shouldSatisfy` ("QuasiQuotes.hs:6:1:Warning:" `isInfixOf`)  #if __GLASGOW_HASKELL__ >= 708         it "works with modules using PatternSynonyms" $ do             withDirectory_ "test/data/pattern-synonyms" $ do-                res <- runID $ checkSyntax ["B.hs"]+                res <- runD $ checkSyntax ["B.hs"]                 res `shouldSatisfy` ("B.hs:6:9:Warning:" `isPrefixOf`) #endif          it "works with foreign exports" $ do-            withDirectory_ "test/data" $ do-                res <- runID $ checkSyntax ["ForeignExport.hs"]+            withDirectory_ "test/data/foreign-export" $ do+                res <- runD $ checkSyntax ["ForeignExport.hs"]                 res `shouldBe` ""          context "when no errors are found" $ do             it "doesn't output an empty line" $ do-                withDirectory_ "test/data/ghc-mod-check/Data" $ do-                    res <- runID $ checkSyntax ["Foo.hs"]+                withDirectory_ "test/data/ghc-mod-check/lib/Data" $ do+                    res <- runD $ checkSyntax ["Foo.hs"]                     res `shouldBe` ""++#if __GLASGOW_HASKELL__ >= 708+-- See https://github.com/kazu-yamamoto/ghc-mod/issues/507+        it "emits warnings generated in GHC's desugar stage" $ do+            withDirectory_ "test/data/check-missing-warnings" $ do+                res <- runD $ checkSyntax ["DesugarWarnings.hs"]+                res `shouldSatisfy` ("DesugarWarnings.hs:4:9:Warning: Pattern match(es) are non-exhaustive\NULIn a case alternative: Patterns not matched:" `isPrefixOf`)+#endif++        it "works with cabal builtin preprocessors" $ do+            withDirectory_ "test/data/cabal-preprocessors" $ do+                _ <- system "cabal clean"+                _ <- system "cabal build"+                res <- runD $ checkSyntax ["Main.hs"]+                res `shouldBe` "Preprocessed.hsc:3:1:Warning: Top-level binding with no type signature: warning :: ()\n"++        it "Uses the right qualification style" $ do+            withDirectory_ "test/data/nice-qualification" $ do+                res <- runD $ checkSyntax ["NiceQualification.hs"]+#if __GLASGOW_HASKELL__ >= 800+                res `shouldBe` "NiceQualification.hs:4:8:\8226 Couldn't match expected type \8216IO ()\8217 with actual type \8216[Char]\8217\NUL\8226 In the expression: \"wrong type\"\NUL  In an equation for \8216main\8217: main = \"wrong type\"\n"+#elif __GLASGOW_HASKELL__ >= 708+                res `shouldBe` "NiceQualification.hs:4:8:Couldn't match expected type \8216IO ()\8217 with actual type \8216[Char]\8217\NULIn the expression: \"wrong type\"\NULIn an equation for \8216main\8217: main = \"wrong type\"\n"+#else+                res `shouldBe` "NiceQualification.hs:4:8:Couldn't match expected type `IO ()' with actual type `[Char]'\NULIn the expression: \"wrong type\"\NULIn an equation for `main': main = \"wrong type\"\n"+#endif
+ test/CradleSpec.hs view
@@ -0,0 +1,67 @@+module CradleSpec where++import Control.Applicative+import Data.List (isSuffixOf)+import GhcMod.Cradle+import GhcMod.Types+import System.Directory (canonicalizePath)+import System.FilePath (pathSeparator)+import Test.Hspec+import TestUtils+import Prelude++import Dir++clean_ :: IO Cradle -> IO Cradle+clean_ f = do+  crdl <- f+  cleanupCradle crdl+  return crdl++relativeCradle :: FilePath -> Cradle -> Cradle+relativeCradle dir crdl = crdl {+    cradleCurrentDir    = toRelativeDir dir  $  cradleCurrentDir crdl+  , cradleRootDir       = toRelativeDir dir  $  cradleRootDir    crdl+  , cradleCabalFile     = toRelativeDir dir <$> cradleCabalFile  crdl+  }++-- Work around GHC 7.2.2 where `canonicalizePath "/"` returns "/.".+stripLastDot :: FilePath -> FilePath+stripLastDot path+  | (pathSeparator:'.':"") `isSuffixOf` path = init path+  | otherwise = path++spec :: Spec+spec = do+    describe "findCradle" $ do+        it "returns the current directory" $ do+            withDirectory_ "/" $ do+                curDir <- stripLastDot <$> canonicalizePath "/"+                res <- clean_ $ runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions+                cradleCurrentDir res `shouldBe` curDir+                cradleRootDir    res `shouldBe` curDir+                cradleCabalFile  res `shouldBe` Nothing++        it "finds a cabal file and a sandbox" $ do+            withDirectory "test/data/cabal-project/subdir1/subdir2" $ \dir -> do+                res <- relativeCradle dir <$> clean_ (runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions)++                cradleCurrentDir res `shouldBe`+                    "test/data/cabal-project/subdir1/subdir2"++                cradleRootDir    res `shouldBe` "test/data/cabal-project"++                cradleCabalFile  res `shouldBe`+                    Just ("test/data/cabal-project/cabalapi.cabal")++        it "works even if a sandbox config file is broken" $ do+            withDirectory "test/data/broken-sandbox" $ \dir -> do+                res <- relativeCradle dir <$> clean_ (runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions)+                cradleCurrentDir res `shouldBe`+                    "test" </> "data" </> "broken-sandbox"++                cradleRootDir    res `shouldBe`+                    "test" </> "data" </> "broken-sandbox"++                cradleCabalFile  res `shouldBe`+                  Just ("test" </> "data" </> "broken-sandbox" </> "dummy.cabal")
+ test/CustomPackageDbSpec.hs view
@@ -0,0 +1,35 @@+module CustomPackageDbSpec where++import GhcMod.CabalHelper+import GhcMod.CustomPackageDb+import GhcMod.Error+import System.Process+import Test.Hspec+import Prelude++import Dir+import TestUtils++spec :: Spec+spec = do+    describe "getCustomPkgDbStack" $ do+        it "works" $ do+            let tdir = "test/data/custom-cradle"+            Just stack <- runD' tdir $ getCustomPkgDbStack+            stack `shouldBe` [ GlobalDb+                             , UserDb+                             , PackageDb "package-db-a"+                             , PackageDb "package-db-b"+                             , PackageDb "package-db-c"+                             ]++    describe "getPackageDbStack'" $ do+        it "fixes out of sync custom pkg-db stack" $ do+            withDirectory_ "test/data/custom-cradle" $ do+                _ <- system "cabal configure"+                (s, s') <- runD $ do+                    Just stack <- getCustomPkgDbStack+                    withCabal $ do+                        stack' <- getCabalPackageDbStack+                        return (stack, stack')+                s' `shouldBe` s
test/Dir.hs view
@@ -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
+ test/FileMappingSpec.hs view
@@ -0,0 +1,259 @@+module FileMappingSpec where++import GhcMod.FileMapping+import GhcMod.Utils (withMappedFile)+import Test.Hspec+import TestUtils+import qualified Data.Map as M+import Dir+import System.IO.Temp+import System.Directory++import GhcMod++spec :: Spec+spec = do+      describe "loadMappedFile" $ do+        it "inserts a given FilePath FileMapping into state with canonicalized path" $ do+          withDirectory_ "test/data/file-mapping" $ do+            mappedFiles <- runD $ do+              loadMappedFile "File.hs" "File.hs"+              getMMappedFiles+            dir <- getCurrentDirectory+            show mappedFiles `shouldBe` show (M.fromList [(dir </> "File.hs", FileMapping "File.hs" False)])+        it "should try to guess a canonical name if file doesn't exist" $ do+          withDirectory_ "test/data/file-mapping" $ do+            mappedFiles <- runD $ do+              loadMappedFile "NonExistantFile.hs" "File.hs"+              getMMappedFiles+            dir <- getCurrentDirectory+            show mappedFiles `shouldBe` show (M.fromList [(dir </> "NonExistantFile.hs", FileMapping "File.hs" False)])++      describe "loadMappedFileSource" $ do+        it "inserts a given FilePath FileMapping into state with canonicalized path" $ do+          withDirectory_ "test/data/file-mapping" $ do+            mappedFiles <- runD $ do+              loadMappedFileSource "File.hs" "main :: IO ()"+              getMMappedFiles+            dir <- getCurrentDirectory+            -- TODO+            M.toList mappedFiles `shouldSatisfy` \[(fn, FileMapping _to True)] ->+              fn == dir </> "File.hs"+        it "should try to guess a canonical name if file doesn't exist" $ do+          withDirectory_ "test/data/file-mapping" $ do+            mappedFiles <- runD $ do+              loadMappedFileSource "NonExistantFile.hs" "main :: IO ()"+              getMMappedFiles+            dir <- getCurrentDirectory+            -- TODO+            M.toList mappedFiles `shouldSatisfy` \[(fn, FileMapping _to True)] ->+              fn == dir </> "NonExistantFile.hs"++      describe "unloadMappedFile" $ do+        it "removes a given FilePath from state" $ do+          withDirectory_ "test/data/file-mapping" $ do+            mappedFiles <- runD $ do+              loadMappedFile "File.hs" "File2.hs"+              unloadMappedFile "File.hs"+              getMMappedFiles+            show mappedFiles `shouldBe` show (M.fromList ([] :: [(FilePath, FileMapping)]))+        it "should work even if file does not exist" $ do+          withDirectory_ "test/data/file-mapping" $ do+            mappedFiles <- runD $ do+              loadMappedFile "NonExistantFile.hs" "File2.hs"+              unloadMappedFile "NonExistantFile.hs"+              getMMappedFiles+            show mappedFiles `shouldBe` show (M.fromList ([] :: [(FilePath, FileMapping)]))+        it "should remove created temporary files" $ do+          withDirectory_ "test/data/file-mapping" $ do+            dir <- getCurrentDirectory+            fileExists <- runD $ do+              loadMappedFileSource "NonExistantFile.hs" "main :: IO ()"+              fp <- maybe undefined fmPath `fmap` lookupMMappedFile (dir </> "NonExistantFile.hs")+              unloadMappedFile "NonExistantFile.hs"+              liftIO $ doesFileExist fp+            not fileExists `shouldBe` True++      describe "withMappedFile" $ do+        it "checks if there is a redirected file and calls and action with its FilePath" $ do+          withDirectory_ "test/data/file-mapping" $ do+            res <- runD $ do+              loadMappedFile "File.hs" "File_Redir.hs"+              withMappedFile "File.hs" return+            res `shouldBe` "File_Redir.hs"+        it "checks if there is an in-memory file and calls and action with temporary file" $ do+          withDirectory_ "test/data/file-mapping" $ do+            (fn, src) <- runD $ do+              loadMappedFileSource "File.hs" "main = test"+              withMappedFile "File.hs" $ \fn -> do+                src <- liftIO $ readFile fn+                return (fn, src)+            fn `shouldSatisfy` (/="File.hs")+            src `shouldBe` "main = test"+        it "runs action with original filename if there is no mapping" $ do+          withDirectory_ "test/data/file-mapping" $ do+            fn <- runD $ do+              withMappedFile "File.hs" return+            fn `shouldBe` "File.hs"++      describe "integration tests" $ do+        it "checks redirected file if one is specified and outputs original filename" $ do+          withDirectory_ "test/data/file-mapping" $ do+            let fm = [("File.hs", "File_Redir.hs")]+            res <- run defaultOptions $ do+              mapM_ (uncurry loadMappedFile) fm+              checkSyntax ["File.hs"]+            res `shouldBe` "File.hs:1:1:Warning: Top-level binding with no type signature: main :: IO ()\n"+        it "checks in-memory file if one is specified and outputs original filename" $ do+          withDirectory_ "test/data/file-mapping" $ do+            let fm = [("File.hs", "main = putStrLn \"Hello World!\"\n")]+            res <- run defaultOptions $ do+              mapM_ (uncurry loadMappedFileSource) fm+              checkSyntax ["File.hs"]+            res `shouldBe` "File.hs:1:1:Warning: Top-level binding with no type signature: main :: IO ()\n"+        it "should work even if file doesn't exist" $ do+          withDirectory_ "test/data/file-mapping" $ do+            let fm = [("Nonexistent.hs", "main = putStrLn \"Hello World!\"\n")]+            res <- run defaultOptions $ do+              mapM_ (uncurry loadMappedFileSource) fm+              checkSyntax ["Nonexistent.hs"]+            res `shouldBe` "Nonexistent.hs:1:1:Warning: Top-level binding with no type signature: main :: IO ()\n"+        it "lints redirected file if one is specified and outputs original filename" $ do+          withDirectory_ "test/data/file-mapping" $ do+            res <- runD $ do+              loadMappedFile "File.hs" "File_Redir_Lint.hs"+              lint lintOpts "File.hs"+            res `shouldBe` "File.hs:4:1: Warning: Eta reduce\NULFound:\NUL  func a b = (*) a b\NULWhy not:\NUL  func = (*)\n"+        it "lints in-memory file if one is specified and outputs original filename" $ do+          withDirectory_ "test/data/file-mapping" $ do+            res <- runD $ do+              loadMappedFileSource "File.hs" "func a b = (++) a b\n"+              lint lintOpts "File.hs"+            res `shouldBe` "File.hs:1:1: Warning: Eta reduce\NULFound:\NUL  func a b = (++) a b\NULWhy not:\NUL  func = (++)\n"+        it "shows types of the expression for redirected files" $ do+            let tdir = "test/data/file-mapping"+            res <- runD' tdir $ do+              loadMappedFile "File.hs" "File_Redir_Lint.hs"+              types False "File.hs" 4 12+            res `shouldBe` "4 12 4 15 \"a -> a -> a\"\n4 12 4 17 \"a -> a\"\n4 12 4 19 \"a\"\n4 1 4 19 \"a -> a -> a\"\n"+        it "shows types of the expression with constraints for redirected files" $ do --+            let tdir = "test/data/file-mapping"+            res <- runD' tdir $ do+              loadMappedFile "File.hs" "File_Redir_Lint.hs"+              types True "File.hs" 4 12+            res `shouldBe` "4 12 4 15 \"a -> a -> a\"\n4 12 4 17 \"a -> a\"\n4 12 4 19 \"a\"\n4 1 4 19 \"Num a => a -> a -> a\"\n"+        it "shows types of the expression for in-memory files" $ do+            let tdir = "test/data/file-mapping"+            res <- runD' tdir $ do+              loadMappedFileSource "File.hs" "main = putStrLn \"Hello!\""+              types False "File.hs" 1 14+            res `shouldBe` "1 8 1 16 \"String -> IO ()\"\n1 8 1 25 \"IO ()\"\n1 1 1 25 \"IO ()\"\n"+        it "shows info for the expression for redirected files" $ do+            let tdir = "test/data/file-mapping"+            res <- runD' tdir $ do+              loadMappedFile "File.hs" "File_Redir_Lint.hs"+              info "File.hs" $ Expression "func"+            res `shouldBe` "func :: Num a => a -> a -> a \t-- Defined at File.hs:4:1\n"+        it "shows info for the expression for in-memory files" $ do+            let tdir = "test/data/file-mapping"+            res <- runD' tdir $ do+              loadMappedFileSource "File.hs" "module File where\n\ntestfun = putStrLn \"Hello!\""+              info "File.hs" $ Expression "testfun"+            res `shouldBe` "testfun :: IO () \t-- Defined at File.hs:3:1\n"++      describe "preprocessor tests" $ do+        it "checks redirected file if one is specified and outputs original filename" $ do+          withDirectory_ "test/data/file-mapping/preprocessor" $ do+            let fm = [("File.hs", "File_Redir.hs")]+            res <- run defaultOptions $ do+              mapM_ (uncurry loadMappedFile) fm+              checkSyntax ["File.hs"]+            res `shouldBe` "File.hs:3:1:Warning: Top-level binding with no type signature: main :: IO ()\n"+        it "works with full path as well" $ do+          withDirectory_ "test/data/file-mapping/preprocessor" $ do+            cwd <- getCurrentDirectory+            let fm = [("File.hs", cwd </> "File_Redir.hs")]+            res <- run defaultOptions $ do+              mapM_ (uncurry loadMappedFile) fm+              checkSyntax ["File.hs"]+            res `shouldBe` "File.hs:3:1:Warning: Top-level binding with no type signature: main :: IO ()\n"+        it "checks in-memory file" $ do+          withDirectory_ "test/data/file-mapping/preprocessor" $ do+            src <- readFile "File_Redir.hs"+            let fm = [("File.hs", src)]+            res <- run defaultOptions $ do+              mapM_ (uncurry loadMappedFileSource) fm+              checkSyntax ["File.hs"]+            res `shouldBe` "File.hs:3:1:Warning: Top-level binding with no type signature: main :: IO ()\n"+        it "lints redirected file if one is specified and outputs original filename" $ do+          withDirectory_ "test/data/file-mapping/preprocessor" $ do+            res <- runD $ do+              loadMappedFile "File.hs" "File_Redir_Lint.hs"+              lint lintOpts "File.hs"+            res `shouldBe` "File.hs:6:1: Warning: Eta reduce\NULFound:\NUL  func a b = (*) a b\NULWhy not:\NUL  func = (*)\n"+        it "lints in-memory file if one is specified and outputs original filename" $ do+          withDirectory_ "test/data/file-mapping/preprocessor" $ do+            src <- readFile "File_Redir_Lint.hs"+            res <- runD $ do+              loadMappedFileSource "File.hs" src+              lint lintOpts "File.hs"+            res `shouldBe` "File.hs:6:1: Warning: Eta reduce\NULFound:\NUL  func a b = (*) a b\NULWhy not:\NUL  func = (*)\n"+      describe "literate haskell tests" $ do+        it "checks redirected file if one is specified and outputs original filename" $ do+          withDirectory_ "test/data/file-mapping/lhs" $ do+            let fm = [("File.lhs", "File_Redir.lhs")]+            res <- run defaultOptions $ do+              mapM_ (uncurry loadMappedFile) fm+              checkSyntax ["File.lhs"]+            res `shouldBe` "File.lhs:1:3:Warning: Top-level binding with no type signature: main :: IO ()\n"+        it "checks in-memory file if one is specified and outputs original filename" $ do+          withDirectory_ "test/data/file-mapping/lhs" $ do+            src <- readFile "File_Redir.lhs"+            let fm = [("File.lhs", src)]+            res <- run defaultOptions $ do+              mapM_ (uncurry loadMappedFileSource) fm+              checkSyntax ["File.lhs"]+            res `shouldBe` "File.lhs:1:3:Warning: Top-level binding with no type signature: main :: IO ()\n"+        -- NOTE: There is a bug in hlint that prevents it from linting lhs files.+        -- it "lints redirected file if one is specified and outputs original filename" $ do+        --   withDirectory_ "test/data/file-mapping/lhs" $ do+        --     res <- runD $ do+        --       loadMappedFile "File.lhs" (RedirectedMapping "File_Redir_Lint.lhs")+        --       lint "File.lhs"+        --     res `shouldBe` "File.lhs:6:1: Error: Eta reduce\NULFound:\NUL  func a b = (*) a b\NULWhy not:\NUL  func = (*)\n"+        -- it "lints in-memory file if one is specified and outputs original filename" $ do+        --   withDirectory_ "test/data/file-mapping/lhs" $ do+        --     src <- readFile "File_Redir_Lint.lhs"+        --     res <- runD $ do+        --       loadMappedFile "File.lhs" (MemoryMapping $ Just src)+        --       lint "File.lhs"+        --     res `shouldBe` "File.lhs:6:1: Error: Eta reduce\NULFound:\NUL  func a b = (*) a b\NULWhy not:\NUL  func = (*)\n"+      describe "template haskell" $ do+        it "works with a redirected module using TemplateHaskell" $ do+          withSystemTempDirectory "ghc-mod-test" $ \tmpdir -> do+            srcFoo <- readFile "test/data/template-haskell/Foo.hs"+            srcBar <- readFile "test/data/template-haskell/Bar.hs"+            withDirectory_ "test/data/file-mapping" $ do+              writeFile (tmpdir </> "Foo_Redir.hs") srcFoo+              writeFile (tmpdir </> "Bar_Redir.hs") srcBar+              let fm = [("Foo.hs", tmpdir </> "Foo_Redir.hs")+                       ,("Bar.hs", tmpdir </> "Bar_Redir.hs")]+              res <- run defaultOptions $ do+                mapM_ (uncurry loadMappedFile) fm+                types False "Bar.hs" 5 1+              res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]+        it "works with a memory module using TemplateHaskell" $ do+          srcFoo <- readFile "test/data/template-haskell/Foo.hs"+          srcBar <- readFile "test/data/template-haskell/Bar.hs"+          withDirectory_ "test/data/file-mapping" $ do+            let fm = [("Foo.hs", srcFoo)+                     ,("Bar.hs", srcBar)]+            res <- run defaultOptions $ do+              mapM_ (uncurry loadMappedFileSource) fm+              types False "Bar.hs" 5 1+            res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]+++lintOpts :: LintOpts+lintOpts =+    defaultLintOpts { optLintHlintOpts = ["--ignore=Use module export list"] }
+ test/FindSpec.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE OverloadedStrings #-}+module FindSpec where++import GhcMod.Exe.Find+import Test.Hspec+import TestUtils++spec :: Spec+spec = do+    describe "db <- loadSymbolDb" $ do+        it "lookupSymbol' db \"head\"  contains at least `Data.List'" $ do+            db <- runD $ loadSymbolDb+            lookupSym "head" db `shouldContain` [ModuleString "Data.List"]
test/FlagSpec.hs view
@@ -1,13 +1,14 @@ module FlagSpec where  import Control.Applicative-import Language.Haskell.GhcMod+import GhcMod import Test.Hspec import TestUtils+import Prelude  spec :: Spec spec = do     describe "flags" $ do-        it "contains at least `-fno-warn-orphans'" $ do+        it "contains at least `-fprint-explicit-foralls" $ do             f <- runD $ lines <$> flags-            f `shouldContain` ["-fno-warn-orphans"]+            f `shouldContain` ["-fprint-explicit-foralls"]
test/GhcPkgSpec.hs view
@@ -1,29 +1,23 @@-{-# LANGUAGE CPP #-} module GhcPkgSpec where -import Language.Haskell.GhcMod.GhcPkg-#if __GLASGOW_HASKELL__ <= 706-import Language.Haskell.GhcMod.Types-#endif--import System.Directory-import System.FilePath ((</>))+import GhcMod.GhcPkg+import GhcMod.CabalHelper+import GhcMod.CustomPackageDb import Test.Hspec+import System.Process (system) +import Dir+import TestUtils+ spec :: Spec spec = do-    describe "getSandboxDb" $ do--- ghc < 7.8-#if __GLASGOW_HASKELL__ <= 706-        it "does include a sandbox with ghc < 7.8" $ do-            cwd <- getCurrentDirectory-            getPackageDbStack "test/data/" `shouldReturn` [GlobalDb, PackageDb $ cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"]-#endif--        it "can parse a config file and extract the sandbox package-db" $ do-            cwd <- getCurrentDirectory-            pkgDb <- getSandboxDb "test/data/"-            pkgDb `shouldBe` (cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d")--        it "throws an error if the sandbox config file is broken" $ do-            getSandboxDb "test/data/broken-sandbox" `shouldThrow` anyException+    describe "getPackageDbStack'" $ do+        it "fixes out of sync custom pkg-db stack" $ do+            withDirectory_ "test/data/custom-cradle" $ do+                _ <- system "cabal configure"+                (s, s') <- runD $ do+                    Just stack <- getCustomPkgDbStack+                    withCabal $ do+                        stack' <- getPackageDbStack+                        return (stack, stack')+                s' `shouldBe` s
+ test/HomeModuleGraphSpec.hs view
@@ -0,0 +1,178 @@+-- ghc-mod: Happy Haskell Hacking+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE OverloadedStrings #-}++module HomeModuleGraphSpec where++import GhcMod.HomeModuleGraph+import GhcMod.LightGhc+import TestUtils++import GHC+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Maybe++import Test.Hspec++runAGhc :: [GHCOption] -> (HscEnv -> LightGhc a) -> IO a+runAGhc opts action = withLightHscEnv opts $ \env -> do+  runLightGhc env $ getSession >>= action++hmGraph :: FilePath -> [String] -> String -> IO GmModuleGraph+hmGraph dir opts mn = runAGhc opts $ \env -> liftIO $ do+    runD' dir $ do+      smp <- liftIO $ findModulePathSet env [mkModuleName mn]+      homeModuleGraph env smp++uhmGraph :: FilePath -> [String] -> String -> String -> GmModuleGraph -> IO GmModuleGraph+uhmGraph dir opts mn umn g = runAGhc opts $ \env -> liftIO $ do+    runD' dir $ do+      smp <- liftIO $ findModulePathSet env [mkModuleName mn]+      usmp <- liftIO $ findModulePathSet env [mkModuleName umn]+      updateHomeModuleGraph env g smp usmp++mapMap :: (Ord k, Ord k')+  => (k -> k') -> (a -> a') -> Map.Map k a -> Map.Map k' a'+mapMap fk fa = Map.mapKeys fk . Map.map fa++mapMpFn :: (FilePath -> FilePath) -> ModulePath -> ModulePath+mapMpFn f (ModulePath mn fn) = ModulePath mn (f fn)++mp :: ModuleName -> ModulePath+mp mn = ModulePath mn $ moduleNameString mn ++ ".hs"++spec :: Spec+spec = do+    describe "reachable" $ do+        let+            smp =+              Set.fromList+                [ mp "A"+                , mp "B"+                , mp "C"+                , mp "D"+                , mp "E"+                , mp "F"+                , mp "G"+                , mp "H"+                , mp "I"+                ]++            moduleMap = mkModuleMap smp++            completeGraph =+                Map.map (Set.map lookupMM) . Map.mapKeys lookupMM++            lookupMM = fromJust . flip Map.lookup moduleMap++            graph = completeGraph $+              Map.fromList+                [ ("A", Set.fromList ["B"])+                , ("B", Set.fromList ["C", "D"])+                , ("C", Set.fromList ["F"])+                , ("D", Set.fromList ["E"])+                , ("E", Set.fromList [])+                , ("F", Set.fromList [])+                , ("G", Set.fromList [])+                , ("H", Set.fromList [])+                , ("I", Set.fromList [])+                ]++            really_reachable =+              Set.fromList+                [ mp "A"+                , mp "B"+                , mp "C"+                , mp "D"+                , mp "E"+                , mp "F"+                ]++            g = GmModuleGraph {+               gmgGraph     = graph+             }++        it "reachable Set.empty g == Set.empty" $ do+            reachable Set.empty g `shouldBe` Set.empty++        it "lists only reachable nodes" $ do+            reachable (Set.fromList [mp "A"]) g `shouldBe` really_reachable+++    describe "homeModuleGraph" $ do+        it "cycles don't break it" $ do+            let tdir = "test/data/home-module-graph/cycle"+            g <- hmGraph tdir [] "A"+            gmgGraph g `shouldBe`+              Map.fromList+                [ (mp "A",  Set.fromList [mp "B"])+                , (mp "B",  Set.fromList [mp "A"])+                ]++        it "follows imports" $ do+            let tdir = "test/data/home-module-graph/indirect"+            g <- hmGraph tdir [] "A"+            gmgGraph g `shouldBe`+              Map.fromList+                [ (mp "A",  Set.fromList [mp "A1", mp "A2", mp "A3"])+                , (mp "A1", Set.fromList [mp "B"])+                , (mp "A2", Set.fromList [mp "C"])+                , (mp "A3", Set.fromList [mp "B"])+                , (mp "B",  Set.fromList [])+                , (mp "C",  Set.fromList [])+                ]++        it "returns partial results on parse errors" $ do+            let tdir = "test/data/home-module-graph/errors"+            g <- hmGraph tdir [] "A"+            gmgGraph g `shouldBe`+              Map.fromList+                [ (mp "A",  Set.fromList [mp "A1", mp "A2", mp "A3"])+                , (mp "A1", Set.fromList [])  -- parse error here+                , (mp "A2", Set.fromList [])+                , (mp "A3", Set.fromList [mp "B"])+                , (mp "B",  Set.fromList [])+                ]++        it "returns partial results on CPP errors" $ do+            let tdir = "test/data/home-module-graph/cpp"+            g <- hmGraph tdir [] "A"+            gmgGraph g `shouldBe`+              Map.fromList+                [ (mp "A",  Set.fromList [mp "A1", mp "A2", mp "A3"])+                , (mp "A1", Set.fromList [])  -- CPP error here+                , (mp "A2", Set.fromList [])+                , (mp "A3", Set.fromList [mp "B"])+                , (mp "B",  Set.fromList [])+                ]++    describe "updateHomeModuleGraph" $ do+        it "removes unreachable nodes" $ do+            let tdir = "test/data/home-module-graph/indirect"+            let tdir' = "test/data/home-module-graph/indirect-update"+            ig <- hmGraph tdir [] "A"+            g <- uhmGraph tdir' [] "A" "A2" ig+            gmgGraph g `shouldBe`+              Map.fromList+                [ (mp "A",  Set.fromList [mp "A1", mp "A2", mp "A3"])+                , (mp "A1", Set.fromList [mp "B"])+                , (mp "A2", Set.fromList [])+                , (mp "A3", Set.fromList [mp "B"])+                , (mp "B",  Set.fromList [])+                -- C was removed+                ]
test/InfoSpec.hs view
@@ -1,59 +1,66 @@ {-# LANGUAGE CPP #-} module InfoSpec where -import Control.Applicative ((<$>))+import Control.Applicative import Data.List (isPrefixOf)-import Language.Haskell.GhcMod+import GhcMod #if __GLASGOW_HASKELL__ < 706 import System.Environment.Executable (getExecutablePath) #else import System.Environment (getExecutablePath) #endif-import System.Exit import System.FilePath-import System.Process import Test.Hspec import TestUtils-import Dir+import Prelude  spec :: Spec spec = do     describe "types" $ do         it "shows types of the expression and its outers" $ do-            withDirectory_ "test/data/ghc-mod-check" $ do-                res <- runD $ types "Data/Foo.hs" 9 5-                res `shouldBe` "9 5 11 40 \"Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n"+            let tdir = "test/data/ghc-mod-check"+            res <- runD' tdir $ types False "lib/Data/Foo.hs" 9 5+#if __GLASGOW_HASKELL__ >= 800+            res `shouldBe` "9 5 11 40 \"Int -> t -> t -> t\"\n7 1 11 40 \"Int -> Integer\"\n"+#else+            res `shouldBe` "9 5 11 40 \"Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n"+#endif ++        it "shows types of the expression with constraints and its outers" $ do+            let tdir = "test/data/ghc-mod-check"+            res <- runD' tdir $ types True "lib/Data/Foo.hs" 9 5+#if __GLASGOW_HASKELL__ >= 800+            res `shouldBe` "9 5 11 40 \"Num t => Int -> t -> t -> t\"\n7 1 11 40 \"Int -> Integer\"\n"+#else+            res `shouldBe` "9 5 11 40 \"Num a => Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n"+#endif+         it "works with a module using TemplateHaskell" $ do-            withDirectory_ "test/data" $ do-                res <- runD $ types "Bar.hs" 5 1-                res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]+            let tdir = "test/data/template-haskell"+            res <- runD' tdir $ types False "Bar.hs" 5 1+            res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]          it "works with a module that imports another module using TemplateHaskell" $ do-            withDirectory_ "test/data" $ do-                res <- runD $ types "Main.hs" 3 8-                res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""]+            let tdir = "test/data/template-haskell"+            res <- runD' tdir $ types False "ImportsTH.hs" 3 8+            res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""]      describe "info" $ do-        it "works for non-export functions" $ do-            withDirectory_ "test/data" $ do-                res <- runD $ info "Info.hs" "fib"-                res `shouldSatisfy` ("fib :: Int -> Int" `isPrefixOf`)+        it "works for non exported functions" $ do+            let tdir = "test/data/non-exported"+            res <- runD' tdir $ info "Fib.hs" $ Expression "fib"+            res `shouldSatisfy` ("fib :: Int -> Int" `isPrefixOf`)          it "works with a module using TemplateHaskell" $ do-            withDirectory_ "test/data" $ do-                res <- runD $ info "Bar.hs" "foo"-                res `shouldSatisfy` ("foo :: ExpQ" `isPrefixOf`)+            let tdir = "test/data/template-haskell"+            res <- runD' tdir $ info "Bar.hs" $ Expression "foo"+            res `shouldSatisfy` ("foo :: ExpQ" `isPrefixOf`)          it "works with a module that imports another module using TemplateHaskell" $ do-            withDirectory_ "test/data" $ do-                res <- runD $ info "Main.hs" "bar"-                res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`)--        it "doesn't fail on unicode output" $ do-            dir <- getDistDir-            code <- rawSystem (dir </> "build/ghc-mod/ghc-mod") ["info", "test/data/Unicode.hs", "Unicode", "unicode"]-            code `shouldSatisfy` (== ExitSuccess)+            let tdir = "test/data/template-haskell"+            res <- runD' tdir $ info "ImportsTH.hs" $ Expression "bar"+            res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`)  getDistDir :: IO FilePath getDistDir = takeDirectory . takeDirectory . takeDirectory <$> getExecutablePath
test/LangSpec.hs view
@@ -1,9 +1,10 @@ module LangSpec where  import Control.Applicative-import Language.Haskell.GhcMod+import GhcMod import Test.Hspec import TestUtils+import Prelude  spec :: Spec spec = do
test/LintSpec.hs view
@@ -1,6 +1,6 @@ module LintSpec where -import Language.Haskell.GhcMod+import GhcMod import Test.Hspec import TestUtils @@ -8,10 +8,14 @@ spec = do     describe "lint" $ do         it "can detect a redundant import" $ do-            res <- runD $ lint "test/data/hlint.hs"-            res `shouldBe` "test/data/hlint.hs:4:8: Error: Redundant do\NULFound:\NUL  do putStrLn \"Hello, world!\"\NULWhy not:\NUL  putStrLn \"Hello, world!\"\n"+            res <- runD $ lint lintOpts "test/data/hlint/hlint.hs"+            res `shouldBe` "test/data/hlint/hlint.hs:4:8: Warning: Redundant do\NULFound:\NUL  do putStrLn \"Hello, world!\"\NULWhy not:\NUL  putStrLn \"Hello, world!\"\n"          context "when no suggestions are given" $ do             it "doesn't output an empty line" $ do-                res <- runD $ lint "test/data/ghc-mod-check/Data/Foo.hs"+                res <- runD $ lint lintOpts "test/data/ghc-mod-check/lib/Data/Foo.hs"                 res `shouldBe` ""++lintOpts :: LintOpts+lintOpts =+    defaultLintOpts { optLintHlintOpts = ["--ignore=Use module export list"] }
test/ListSpec.hs view
@@ -1,13 +1,14 @@ module ListSpec where  import Control.Applicative-import Language.Haskell.GhcMod+import GhcMod import Test.Hspec import TestUtils+import Prelude  spec :: Spec spec = do     describe "modules" $ do         it "contains at least `Data.Map'" $ do-            mdls <- runD $ lines <$> modules+            mdls <- runD $ lines <$> modules False             mdls `shouldContain` ["Data.Map"]
test/Main.hs view
@@ -1,33 +1,94 @@ {-# LANGUAGE CPP, ScopedTypeVariables #-}-import Spec import Dir  import Control.Exception as E import Control.Monad (void)-import Language.Haskell.GhcMod (debugInfo)+import GhcMod (debugInfo) import System.Process+import System.Environment import Test.Hspec import TestUtils +import qualified BrowseSpec+import qualified CabalHelperSpec+import qualified CaseSplitSpec+import qualified CheckSpec+import qualified CradleSpec+import qualified CustomPackageDbSpec+import qualified FileMappingSpec+import qualified FindSpec+import qualified FlagSpec+import qualified GhcPkgSpec+import qualified HomeModuleGraphSpec+import qualified InfoSpec+import qualified LangSpec+import qualified LintSpec+import qualified ListSpec+import qualified MonadSpec+import qualified PathsAndFilesSpec+import qualified ShellParseSpec+import qualified TargetSpec++spec :: Spec+spec = do+  describe "Browse"          BrowseSpec.spec+  describe "CabalHelper"     CabalHelperSpec.spec+  describe "CaseSplit"       CaseSplitSpec.spec+  describe "Check"           CheckSpec.spec+  describe "Cradle"          CradleSpec.spec+  describe "CustomPackageDb" CustomPackageDbSpec.spec+  describe "FileMapping"     FileMappingSpec.spec+  describe "Find"            FindSpec.spec+  describe "Flag"            FlagSpec.spec+  describe "GhcPkg"          GhcPkgSpec.spec+  describe "HomeModuleGraph" HomeModuleGraphSpec.spec+  describe "Info"            InfoSpec.spec+  describe "Lang"            LangSpec.spec+  describe "Lint"            LintSpec.spec+  describe "List"            ListSpec.spec+  describe "Monad"           MonadSpec.spec+  describe "PathsAndFiles"   PathsAndFilesSpec.spec+  describe "ShellParse"      ShellParseSpec.spec+  describe "Target"          TargetSpec.spec+ main :: IO () main = do-  let sandboxes = [ "test/data", "test/data/check-packageid"+#if __GLASGOW_HASKELL__ >= 708+  unsetEnv "GHC_PACKAGE_PATH"+#endif+  let sandboxes = [ "test/data/cabal-project"+                  , "test/data/check-packageid"                   , "test/data/duplicate-pkgver/"                   , "test/data/broken-cabal/"                   ]       genSandboxCfg dir = withDirectory dir $ \cwdir -> do-         system ("sed 's|@CWD@|" ++ cwdir ++ "|g' cabal.sandbox.config.in > cabal.sandbox.config")+         system ("rm cabal.sandbox.config; cabal sandbox init")       pkgDirs =-        [ "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"+        [ "test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"         , "test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"         , "test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"]       genGhcPkgCache dir = system $ "ghc-pkg recache --force -f" ++ dir-  genSandboxCfg `mapM_` sandboxes-  genGhcPkgCache `mapM_` pkgDirs-  void $ system "find test -name setup-config -name ghc-mod.cache -exec rm {} \\;"++  let cleanCmd = "git clean -dXf test/data/"+  putStrLn $ "$ " ++ cleanCmd+  void $ system cleanCmd   void $ system "cabal --version"-  putStrLn $ "ghc-mod was built with Cabal version " ++ VERSION_Cabal   void $ system "ghc --version"++  genSandboxCfg `mapM_` sandboxes+  genGhcPkgCache `mapM_` pkgDirs++  let stackDir = "test/data/stack-project"+  void $ withDirectory_ stackDir $ do+    let ghcver = let gvn = show (__GLASGOW_HASKELL__ :: Int)+                     (major, minor') = splitAt (length gvn - 2) gvn+                     minor = case dropWhile (=='0') minor' of+                                  "" -> "0"+                                  x  -> x+                 in major ++ "." ++ minor+    void $ system $ "sed '$ a resolver: ghc-" ++ ghcver ++ "' stack.yaml.in > stack.yaml"+    void $ system "stack setup"+    void $ system "stack build"    (putStrLn =<< runD debugInfo)       `E.catch` (\(_ :: E.SomeException) -> return () )
test/MonadSpec.hs view
@@ -1,19 +1,17 @@-{-# LANGUAGE ScopedTypeVariables #-} module MonadSpec where  import Test.Hspec-import Dir import TestUtils-import Control.Applicative-import Control.Exception import Control.Monad.Error.Class+import Control.Concurrent+import Control.Exception  spec :: Spec spec = do     describe "When using GhcModT in a do block" $         it "a pattern match failure causes a call to `fail` on ErrorT in the monad stack" $ do-             (a, _)-                 <- runGhcModT defaultOptions $+             (a, _h)+                 <- runGmOutDef $ runGhcModT defaultOptions $                        do                          Just _ <- return Nothing                          return "hello"@@ -21,19 +19,30 @@              a `shouldBe` (Left $ GMEString "oh noes")      describe "runGhcModT" $-        it "complains if the cabal file fails to parse while a sandbox is present" $ withDirectory_ "test/data/broken-cabal" $ do-          shouldReturnError $ runD' (gmCradle <$> ask)+        it "throws an exception when run in multiple threads" $ do -    describe "gmsGet/Put" $-        it "work" $ do-          (runD $ gmsPut (GhcModState Intelligent) >> gmsGet)-            `shouldReturn` (GhcModState Intelligent)+          mv_ex :: MVar (Either SomeException ())+              <- newEmptyMVar+          mv_startup_barrier :: MVar ()+              <- newEmptyMVar -    describe "liftIO" $ do-        it "converts user errors to GhcModError" $ do-            shouldReturnError $-                runD' $ liftIO $ throw (userError "hello") >> return ""+          _t1 <- forkOS $ do+                 -- wait (inside GhcModT) for t2 to receive the exception+                 _ <- runD $ liftIO $ do+                            putMVar mv_startup_barrier ()+                            readMVar mv_ex+                 return () -        it "converts a file not found exception to GhcModError" $ do-            shouldReturnError $-                runD' $ liftIO $ readFile "/DOES_NOT_EXIST" >> return ""+          _t2 <- forkOS $ do+                 readMVar mv_startup_barrier -- wait for t1 to be in GhcModT+                 res <- try $ runD $ return ()+                 res' <- evaluate res+                 putMVar mv_ex res'++          ex <- takeMVar mv_ex++          isLeft ex `shouldBe` True++isLeft :: Either a b -> Bool+isLeft (Right _) = False+isLeft (Left _) = True
+ test/PathsAndFilesSpec.hs view
@@ -0,0 +1,48 @@+module PathsAndFilesSpec where+++import GhcMod.PathsAndFiles+import GhcMod.Cradle+import qualified GhcMod.Utils as U++import Control.Monad.Trans.Maybe+import System.Directory+import System.FilePath+import Test.Hspec+import TestUtils++spec :: Spec+spec = do+    describe "getSandboxDb" $ do+        it "can parse a config file and extract the sandbox package-db" $ do+            cwd <- getCurrentDirectory+            Just crdl <- runLogDef $ runMaybeT $ plainCradle "test/data/cabal-project"+            Just db <- getSandboxDb crdl+            db `shouldSatisfy` isPkgDbAt (cwd </> "test/data/cabal-project/.cabal-sandbox")++        it "returns Nothing if the sandbox config file is broken" $ do+            Just crdl <- runLogDef $ runMaybeT $ plainCradle "test/data/broken-sandbox"+            getSandboxDb crdl  `shouldReturn` Nothing++    describe "findCabalFile" $ do+        it "works" $ do+            p <- U.makeAbsolute' "test/data/cabal-project/cabalapi.cabal"+            findCabalFile "test/data/cabal-project" `shouldReturn` Just p++        it "finds cabal files in parent directories" $ do+            p <- U.makeAbsolute' "test/data/cabal-project/cabalapi.cabal"+            findCabalFile "test/data/cabal-project/subdir1/subdir2" `shouldReturn` Just p++    describe "findStackConfigFile" $ do+        it "works" $ do+            p <- U.makeAbsolute' "test/data/stack-project/stack.yaml"+            findStackConfigFile "test/data/stack-project" `shouldReturn` Just p++    describe "findCabalSandboxDir" $ do+        it "works" $ do+            p <- U.makeAbsolute' "test/data/cabal-project"+            findCabalSandboxDir "test/data/cabal-project" `shouldReturn` Just p++        it "finds sandboxes in parent directories" $ do+            p <- U.makeAbsolute' "test/data/cabal-project"+            findCabalSandboxDir "test/data/cabal-project/subdir1/subdir2" `shouldReturn` Just p
+ test/ShellParseSpec.hs view
@@ -0,0 +1,34 @@+module ShellParseSpec where+++import GhcMod.Exe.Options.ShellParse++import Test.Hspec++spec :: Spec+spec =+  describe "parseCmdLine" $ do+    it "splits arguments" $ do+      parseCmdLine "test command line" `shouldBe` ["test", "command", "line"]+      parseCmdLine "ascii-escape test command line" `shouldBe` ["test", "command", "line"]+    it "honors quoted segments if turned on" $+      parseCmdLine "ascii-escape test command line \STXwith quoted segment\ETX"+        `shouldBe` ["test", "command", "line", "with quoted segment"]+    it "doesn't honor quoted segments if turned off" $+      parseCmdLine "test command line \STXwith quoted segment\ETX"+        `shouldBe` words "test command line \STXwith quoted segment\ETX"+    it "squashes multiple spaces" $ do+      parseCmdLine "test       command"+        `shouldBe` ["test", "command"]+      parseCmdLine "ascii-escape           test       command"+        `shouldBe` ["test", "command"]+    it "ingores leading spaces" $ do+      parseCmdLine "     test       command"+        `shouldBe` ["test", "command"]+      parseCmdLine "   ascii-escape           test       command"+        `shouldBe` ["test", "command"]+    it "parses empty string as no argument" $ do+      parseCmdLine ""+        `shouldBe` [""]+      parseCmdLine "ascii-escape "+        `shouldBe` [""]
− test/Spec.hs 
@@ -1,1 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-}
+ test/TargetSpec.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings #-}+module TargetSpec where++import GhcMod.Target+import GhcMod.LightGhc+import GhcMod.Gap+import Test.Hspec++import TestUtils++import GHC+import Data.List+import Data.Maybe+import System.Directory+import System.FilePath++spec :: Spec+spec = do+    describe "runLightGhc" $ do+        it "works at all" $ do+            withLightHscEnv [] $ \env ->+              runLightGhc env (return ()) `shouldReturn` ()++        it "has modules in scope" $ do+            (withLightHscEnv [] $ \env ->+              runLightGhc env $ do+               dflags <- getSessionDynFlags+               let i = intersect (listVisibleModuleNames dflags)+                                 ["Control.Applicative", "Control.Arrow"+                                 ,"Control.Exception", "GHC.Exts", "GHC.Float"]+               liftIO $ i `shouldSatisfy` not . null) :: IO ()++        it "can get module info" $ do+            (withLightHscEnv [] $ \env ->+              runLightGhc env $ do+                mdl <- findModule "Data.List" Nothing+                mmi <- getModuleInfo mdl+                liftIO $ isJust mmi `shouldBe` True) :: IO ()+++    describe "resolveModule" $ do+        it "Works when a module given as path uses CPP" $ do+            dir <- getCurrentDirectory+            let srcDirs = [dir </> "test/data/target/src"]+            x <- withLightHscEnv [] $ \env -> runD $ do+                resolveModule env srcDirs (Left $ dir </> "test/data/target/Cpp.hs")+            liftIO $ x `shouldBe` Just (ModulePath "Cpp" $ dir </> "test/data/target/Cpp.hs")
test/TestUtils.hs view
@@ -1,27 +1,42 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} module TestUtils (     run   , runD   , runD'-  , runI-  , runID-  , runIsolatedGhcMod-  , isolateCradle+  , runE+  , runNullLog+  , runGmOutDef+  , runLogDef   , shouldReturnError-  , module Language.Haskell.GhcMod.Monad-  , module Language.Haskell.GhcMod.Types+  , isPkgDbAt+  , isPkgConfDAt+  , module GhcMod.Monad+  , module GhcMod.Types   ) where -import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.Types+import GhcMod.Logging+import GhcMod.Monad+import GhcMod.Cradle+import GhcMod.Types +import Control.Arrow+import Control.Category+import Control.Applicative+import Control.Monad.Error (ErrorT, runErrorT)+import Control.Monad.Trans.Journal+import Data.List.Split+import Data.Label+import Data.String+import System.FilePath+import System.Directory import Test.Hspec+import Prelude hiding ((.)) -isolateCradle :: IOish m => GhcModT m a -> GhcModT m a-isolateCradle action =-    local modifyEnv  $ action- where-    modifyEnv e = e { gmCradle = (gmCradle e) { cradlePkgDbStack = [GlobalDb] } }+import Exception +testLogLevel :: GmLogLevel+testLogLevel = GmDebug+ extract :: Show e => IO (Either e a, w) -> IO a extract action = do   (r,_) <- action@@ -29,29 +44,57 @@     Right a ->  return a     Left e -> error $ show e -runIsolatedGhcMod :: Options -> GhcModT IO a -> IO a-runIsolatedGhcMod opt action = do-  extract $ runGhcModT opt $ isolateCradle action+runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog)+runGhcModTSpec opt action = do+  dir <- getCurrentDirectory+  runGhcModTSpec' dir opt action --- | Run GhcMod in isolated cradle with default options-runID :: GhcModT IO a -> IO a-runID = runIsolatedGhcMod defaultOptions+runGhcModTSpec' :: IOish m+    => FilePath -> Options -> GhcModT m b -> m (Either GhcModError b, GhcModLog)+runGhcModTSpec' dir opt action = liftIO (canonicalizePath dir) >>= \dir' -> do+  runGmOutT opt $+    withGhcModEnv' withSpecCradle dir' opt $ \(env,_) -> do+      first (fst <$>) <$> runGhcModT' env defaultGhcModState+        (gmSetLogLevel (ooptLogLevel $ optOutput opt) >> action)+ where+   withSpecCradle :: (IOish m, GmOut m) => FilePath -> ((Cradle, GhcModLog) -> m a) -> m a+   withSpecCradle cradledir f =+     gbracket+       (runJournalT $ findSpecCradle (optPrograms opt) cradledir)+       (liftIO . cleanupCradle . fst) f --- | Run GhcMod in isolated cradle-runI :: Options -> GhcModT IO a -> IO a-runI = runIsolatedGhcMod  -- | Run GhcMod run :: Options -> GhcModT IO a -> IO a-run opt a = extract $ runGhcModT opt a+run opt a = extract $ runGhcModTSpec opt a  -- | Run GhcMod with default options runD :: GhcModT IO a -> IO a-runD = extract . runGhcModT defaultOptions+runD =+    extract . runGhcModTSpec (setLogLevel testLogLevel defaultOptions) -runD' :: GhcModT IO a -> IO (Either GhcModError a, GhcModLog)-runD' = runGhcModT defaultOptions+runD' :: FilePath -> GhcModT IO a -> IO a+runD' dir =+    extract . runGhcModTSpec' dir (setLogLevel testLogLevel defaultOptions) +setLogLevel :: GmLogLevel -> Options -> Options+setLogLevel = set (lOoptLogLevel . lOptOutput)++runE :: ErrorT e IO a -> IO (Either e a)+runE = runErrorT++runNullLog :: MonadIO m => JournalT GhcModLog m a -> m a+runNullLog action = do+  (a,w) <- runJournalT action+  liftIO $ print w+  return a++runGmOutDef :: IOish m => GmOutT m a -> m a+runGmOutDef = runGmOutT defaultOptions++runLogDef :: IOish m => GmOutT (JournalT GhcModLog m) a -> m a+runLogDef = fmap fst . runJournalT . runGmOutDef+ shouldReturnError :: Show a                   => IO (Either GhcModError a, GhcModLog)                   -> Expectation@@ -61,3 +104,21 @@  where    isLeft (Left _) = True    isLeft _ = False++isPkgConfD :: FilePath -> Bool+isPkgConfD d = let+    (_dir, pkgconfd) = splitFileName d+    in case splitOn "-" pkgconfd of+         [_arch, _platform, _compiler, _compver, "packages.conf.d"] -> True+         _ -> False++isPkgConfDAt :: FilePath -> FilePath -> Bool+isPkgConfDAt d d' | d == takeDirectory d' && isPkgConfD d' = True+isPkgConfDAt _ _ = False++isPkgDbAt :: FilePath -> GhcPkgDb -> Bool+isPkgDbAt d (PackageDb dir) = isPkgConfDAt d dir+isPkgDbAt _ _ = False++instance IsString ModuleName where+    fromString = mkModuleName
− test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf 
@@ -1,4 +0,0 @@-name: Cabal-version: 1.18.1.3-id: Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b-exposed: True
− test/data/.cabal-sandbox/packages/00-index.tar

binary file changed (10240 → absent bytes)

− test/data/Bar.hs 
@@ -1,5 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Bar (bar) where-import Foo (foo)--bar = $foo ++ "bar"
− test/data/Baz.hs 
@@ -1,5 +0,0 @@-{-# LANGUAGE QuasiQuotes #-}-module Baz (baz) where-import Foo (fooQ)--baz = [fooQ| foo bar baz |]
− test/data/Foo.hs 
@@ -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
− test/data/ForeignExport.hs 
@@ -1,10 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}--module ForeignExport where--import Foreign.C.Types--foreign export ccall foo :: CUInt--foo :: CUInt-foo = 123
− test/data/Info.hs 
@@ -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)
− test/data/Main.hs 
@@ -1,3 +0,0 @@-import Bar (bar)--main = putStrLn bar
− test/data/Mutual1.hs 
@@ -1,5 +0,0 @@-{-# LANGUAGE TemplateHaskell #-} -- for HscInterpreted--module Mutual1 where--import Mutual2
− test/data/Mutual2.hs 
@@ -1,3 +0,0 @@-module Mutual2 where--import Mutual1
− test/data/Unicode.hs 
@@ -1,4 +0,0 @@-module Unicode where--unicode :: α -> α-unicode = id
+ test/data/annotations/With.hs view
@@ -0,0 +1,6 @@+module Main where++{-# ANN module ["this", "can", "be", "anything"] #-}++main :: IO ()+main = putStrLn "Hello world!"
− test/data/broken-cabal/cabal.sandbox.config.in 
@@ -1,25 +0,0 @@--- This is a Cabal package environment file.--- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY.--- Please create a 'cabal.config' file in the same directory--- if you want to change the default settings for this sandbox.---local-repo: @CWD@/test/data/broken-cabal/.cabal-sandbox/packages-logs-dir: @CWD@/test/data/broken-cabal/.cabal-sandbox/logs-world-file: @CWD@/test/data/broken-cabal/.cabal-sandbox/world-user-install: False-package-db: @CWD@/test/data/broken-cabal/.cabal-sandbox/x86_64-linux-ghc-7.8.3-packages.conf.d-build-summary: @CWD@/test/data/broken-cabal/.cabal-sandbox/logs/build.log--install-dirs-  prefix: @CWD@/test/data/broken-cabal/.cabal-sandbox-  bindir: $prefix/bin-  libdir: $prefix/lib-  libsubdir: $arch-$os-$compiler/$pkgid-  libexecdir: $prefix/libexec-  datadir: $prefix/share-  datasubdir: $arch-$os-$compiler/$pkgid-  docdir: $datadir/doc/$arch-$os-$compiler/$pkgid-  htmldir: $docdir/html-  haddockdir: $htmldir-  sysconfdir: $prefix/etc
test/data/cabal-flags/cabal-flags.cabal view
@@ -7,8 +7,7 @@   default: False  library-  build-depends: base == 4.*+  build-depends: base    if flag(test-flag)     build-depends: Cabal >= 1.10-
+ test/data/cabal-preprocessors/Main.hs view
@@ -0,0 +1,4 @@+import Preprocessed++main :: IO ()+main = return warning
+ test/data/cabal-preprocessors/Preprocessed.hsc view
@@ -0,0 +1,3 @@+module Preprocessed where++warning = ()
+ test/data/cabal-preprocessors/cabal-preprocessors.cabal view
@@ -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
+ test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf view
@@ -0,0 +1,4 @@+name: Cabal+version: 1.18.1.3+id: Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b+exposed: True
+ test/data/cabal-project/Baz.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE QuasiQuotes #-}+module Baz (baz) where+import Foo (fooQ)++baz = [fooQ| foo bar baz |]
+ test/data/cabal-project/Foo.hs view
@@ -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
+ test/data/cabal-project/Info.hs view
@@ -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)
+ test/data/cabal-project/Main.hs view
@@ -0,0 +1,3 @@+import Bar (bar)++main = putStrLn bar
+ test/data/cabal-project/cabalapi.cabal view
@@ -0,0 +1,67 @@+Name:                   ghc-mod+Version:                1.11.3+Author:                 Kazu Yamamoto <kazu@iij.ad.jp>+Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp>+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 <https://github.com/eagletmt/ghcmod-vim> or+                        <https://github.com/scrooloose/syntastic>+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
+ test/data/cabal-project/subdir1/subdir2/dummy view
@@ -0,0 +1,1 @@+dummy
− test/data/cabal.sandbox.config.in 
@@ -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
− test/data/cabalapi.cabal 
@@ -1,67 +0,0 @@-Name:                   ghc-mod-Version:                1.11.3-Author:                 Kazu Yamamoto <kazu@iij.ad.jp>-Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp>-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 <https://github.com/eagletmt/ghcmod-vim> or-                        <https://github.com/scrooloose/syntastic>-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
+ test/data/case-split/Crash.hs view
@@ -0,0 +1,4 @@+module Crash where++test :: Maybe a+test x = undefined
+ test/data/case-split/Vect.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE DataKinds, TypeFamilies, TypeOperators, GADTs, KindSignatures #-}++module Vect where++data Nat = Z | S Nat++type family   (n :: Nat) :+ (m :: Nat) :: Nat+type instance Z :+ m = m+type instance S n :+ m = S (n :+ m)++data Vect :: Nat -> * -> * where+  VNil :: Vect Z a+  (:::) :: a -> Vect n a -> Vect (S n) a++vAppend :: Vect n a -> Vect m a -> Vect (n :+ m) a+vAppend x y = _vAppend_body++lAppend :: [a] -> [a] -> [a]+lAppend x y = _lAppend_body++data MyList a = Nil | Cons a (MyList a)++mlAppend :: MyList a -> MyList a -> MyList a+mlAppend x y = _mlAppend_body++mlAppend2 :: MyList a -> MyList a -> MyList a+mlAppend2 x y = case x of+                  x' -> _mlAppend_body++mlReverse :: MyList a -> MyList a+mlReverse xs = mlReverse' xs Nil+  where+    mlReverse' :: MyList a -> MyList a -> MyList a+    mlReverse' xs' accum = _mlReverse_body++mlReverse2 :: MyList a -> MyList a+mlReverse2 xs = let mlReverse' :: MyList a -> MyList a -> MyList a+                    mlReverse' xs' accum = _mlReverse_body+                 in mlReverse' xs Nil
+ test/data/case-split/Vect706.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE DataKinds, TypeFamilies, TypeOperators, GADTs, KindSignatures #-}++module Vect706 where++data Nat = Z | S Nat++type family   (n :: Nat) :+ (m :: Nat) :: Nat+type instance Z :+ m = m+type instance S n :+ m = S (n :+ m)++data Vect :: Nat -> * -> * where+  VNil :: Vect Z a+  (:::) :: a -> Vect n a -> Vect (S n) a++vAppend :: Vect n a -> Vect m a -> Vect (n :+ m) a+vAppend x y = undefined++lAppend :: [a] -> [a] -> [a]+lAppend x y = undefined++data MyList a = Nil | Cons a (MyList a)++mlAppend :: MyList a -> MyList a -> MyList a+mlAppend x y = undefined++mlAppend2 :: MyList a -> MyList a -> MyList a+mlAppend2 x y = case x of+                  x' -> undefined++mlReverse :: MyList a -> MyList a+mlReverse xs = mlReverse' xs Nil+  where+    mlReverse' :: MyList a -> MyList a -> MyList a+    mlReverse' xs' accum = undefined++mlReverse2 :: MyList a -> MyList a+mlReverse2 xs = let mlReverse' :: MyList a -> MyList a -> MyList a+                    mlReverse' xs' accum = undefined+                 in mlReverse' xs Nil
+ test/data/check-missing-warnings/DesugarWarnings.hs view
@@ -0,0 +1,5 @@+module Warnings (zoo) where++zoo :: [a] -> ()+zoo x = case x of+          [] -> undefined
− test/data/check-packageid/cabal.sandbox.config.in 
@@ -1,25 +0,0 @@--- This is a Cabal package environment file.--- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY.--- Please create a 'cabal.config' file in the same directory--- if you want to change the default settings for this sandbox.---local-repo: @CWD@/test/data/check-packageid/.cabal-sandbox/packages-logs-dir: @CWD@/test/data/check-packageid/.cabal-sandbox/logs-world-file: @CWD@/test/data/check-packageid/.cabal-sandbox/world-user-install: False-package-db: @CWD@/test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d-build-summary: @CWD@/test/data/check-packageid/.cabal-sandbox/logs/build.log--install-dirs-  prefix: @CWD@/test/data/check-packageid/.cabal-sandbox-  bindir: $prefix/bin-  libdir: $prefix/lib-  libsubdir: $arch-$os-$compiler/$pkgid-  libexecdir: $prefix/libexec-  datadir: $prefix/share-  datasubdir: $arch-$os-$compiler/$pkgid-  docdir: $datadir/doc/$arch-$os-$compiler/$pkgid-  htmldir: $docdir/html-  haddockdir: $htmldir-  sysconfdir: $prefix/etc
test/data/check-test-subdir/check-test-subdir.cabal view
@@ -13,3 +13,4 @@   build-depends: base == 4.*   hs-source-dirs: test   main-is: Main.hs+  ghc-options: -Wall
+ test/data/custom-cradle/custom-cradle.cabal view
@@ -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
+ test/data/custom-cradle/ghc-mod.package-db-stack view
@@ -0,0 +1,5 @@+global+user+package-db-a+package-db-b+package-db-c
+ test/data/custom-cradle/package-db-a/.gitkeep view
+ test/data/custom-cradle/package-db-b/.gitkeep view
+ test/data/custom-cradle/package-db-c/.gitkeep view
− test/data/duplicate-pkgver/cabal.sandbox.config.in 
@@ -1,25 +0,0 @@--- This is a Cabal package environment file.--- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY.--- Please create a 'cabal.config' file in the same directory--- if you want to change the default settings for this sandbox.---local-repo: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox/packages-logs-dir: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox/logs-world-file: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox/world-user-install: False-package-db: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d-build-summary: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox/logs/build.log--install-dirs-  prefix: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox-  bindir: $prefix/bin-  libdir: $prefix/lib-  libsubdir: $arch-$os-$compiler/$pkgid-  libexecdir: $prefix/libexec-  datadir: $prefix/share-  datasubdir: $arch-$os-$compiler/$pkgid-  docdir: $datadir/doc/$arch-$os-$compiler/$pkgid-  htmldir: $docdir/html-  haddockdir: $htmldir-  sysconfdir: $prefix/etc
+ test/data/file-mapping/File.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Hello World!"
+ test/data/file-mapping/File_Redir.hs view
@@ -0,0 +1,1 @@+main = putStrLn "Hello World!"
+ test/data/file-mapping/File_Redir_Lint.hs view
@@ -0,0 +1,4 @@+module File where++func :: Num a => a -> a -> a+func a b = (*) a b
+ test/data/file-mapping/lhs/File.lhs view
@@ -0,0 +1,2 @@+> main :: IO ()+> main = putStrLn "Hello World!"
+ test/data/file-mapping/lhs/File_Redir.lhs view
@@ -0,0 +1,1 @@+> main = putStrLn "Hello World!"
+ test/data/file-mapping/lhs/File_Redir_Lint.lhs view
@@ -0,0 +1,4 @@+> module File where++> func :: Num a => a -> a -> a+> func a b = (*) a b
+ test/data/file-mapping/preprocessor/File.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE CPP #-}+#ifndef NOTHING+main :: IO ()+main = putStrLn "Hello World!"+#else+INVALID+#endif
+ test/data/file-mapping/preprocessor/File_Redir.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE CPP #-}+#ifndef NOTHING+main = putStrLn "Hello World!"+#else+INVALID+#endif
+ test/data/file-mapping/preprocessor/File_Redir_Lint.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE CPP #-}+#ifndef NOTHING+module File where++func :: Num a => a -> a -> a+func a b = (*) a b+#else+INVALID+#endif
+ test/data/foreign-export/ForeignExport.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE ForeignFunctionInterface #-}++module ForeignExport where++import Foreign.C.Types++foreign export ccall foo :: CUInt++foo :: CUInt+foo = 123
− test/data/ghc-mod-check/Data/Foo.hs 
@@ -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)
test/data/ghc-mod-check/ghc-mod-check.cabal view
@@ -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
+ test/data/ghc-mod-check/lib/Data/Foo.hs view
@@ -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)
− test/data/hlint.hs 
@@ -1,5 +0,0 @@-module Hlist where--main :: IO ()-main = do-    putStrLn "Hello, world!"
+ test/data/hlint/hlint.hs view
@@ -0,0 +1,5 @@+module Hlist where++main :: IO ()+main = do+    putStrLn "Hello, world!"
+ test/data/home-module-graph/cpp/A.hs view
@@ -0,0 +1,4 @@+module A where+import A1+import A2+import A3
+ test/data/home-module-graph/cpp/A1.hs view
@@ -0,0 +1,4 @@+{-# LANGUAGE CPP #-}+module A1 where+#elif+import B
+ test/data/home-module-graph/cpp/A2.hs view
@@ -0,0 +1,1 @@+module A2 where
+ test/data/home-module-graph/cpp/A3.hs view
@@ -0,0 +1,2 @@+module A3 where+import B
+ test/data/home-module-graph/cpp/B.hs view
@@ -0,0 +1,1 @@+module B where
+ test/data/home-module-graph/cycle/A.hs view
@@ -0,0 +1,2 @@+module A where+import B
+ test/data/home-module-graph/cycle/B.hs view
@@ -0,0 +1,2 @@+module B where+import A
+ test/data/home-module-graph/errors/A.hs view
@@ -0,0 +1,4 @@+module A where+import A1+import A2+import A3
+ test/data/home-module-graph/errors/A1.hs view
@@ -0,0 +1,4 @@+module A1 where+psogduapzs9+import B+lx,vLMCks
+ test/data/home-module-graph/errors/A2.hs view
@@ -0,0 +1,1 @@+module A2 where
+ test/data/home-module-graph/errors/A3.hs view
@@ -0,0 +1,2 @@+module A3 where+import B
+ test/data/home-module-graph/errors/B.hs view
@@ -0,0 +1,1 @@+module B where
+ test/data/home-module-graph/indirect-update/A.hs view
@@ -0,0 +1,4 @@+module A where+import A1+import A2+import A3
+ test/data/home-module-graph/indirect-update/A1.hs view
@@ -0,0 +1,2 @@+module A1 where+import B
+ test/data/home-module-graph/indirect-update/A2.hs view
@@ -0,0 +1,1 @@+module A2 where
+ test/data/home-module-graph/indirect-update/A3.hs view
@@ -0,0 +1,2 @@+module A3 where+import B
+ test/data/home-module-graph/indirect-update/B.hs view
@@ -0,0 +1,1 @@+module B where
+ test/data/home-module-graph/indirect-update/C.hs view
@@ -0,0 +1,1 @@+module C where
+ test/data/home-module-graph/indirect/A.hs view
@@ -0,0 +1,4 @@+module A where+import A1+import A2+import A3
+ test/data/home-module-graph/indirect/A1.hs view
@@ -0,0 +1,2 @@+module A1 where+import B
+ test/data/home-module-graph/indirect/A2.hs view
@@ -0,0 +1,2 @@+module A2 where+import C
+ test/data/home-module-graph/indirect/A3.hs view
@@ -0,0 +1,2 @@+module A3 where+import B
+ test/data/home-module-graph/indirect/B.hs view
@@ -0,0 +1,1 @@+module B where
+ test/data/home-module-graph/indirect/C.hs view
@@ -0,0 +1,1 @@+module C where
+ test/data/import-cycle/Mutual1.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE TemplateHaskell #-} -- for HscInterpreted++module Mutual1 where++import Mutual2
+ test/data/import-cycle/Mutual2.hs view
@@ -0,0 +1,3 @@+module Mutual2 where++import Mutual1
+ test/data/nice-qualification/NiceQualification.hs view
@@ -0,0 +1,4 @@+module Main where++main :: IO ()+main = "wrong type"
+ test/data/non-exported/Fib.hs view
@@ -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)
test/data/pattern-synonyms/A.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE PatternSynonyms #-}+ module A where  data SomeType a b = SomeType (a,b)
test/data/pattern-synonyms/pattern-synonyms.cabal view
@@ -1,24 +1,27 @@--- Initial pattern-synonyms.cabal generated by cabal init.  For further +-- Initial pattern-synonyms.cabal generated by cabal init.  For further -- documentation, see http://haskell.org/cabal/users-guide/  name:                pattern-synonyms version:             0.1.0.0--- synopsis:            --- description:         --- license:             +-- synopsis:+-- description:+-- license: license-file:        LICENSE author:              Daniel Gröber maintainer:          dxld@darkboxed.org--- copyright:           --- category:            +-- copyright:+-- category: build-type:          Simple--- extra-source-files:  +-- extra-source-files: cabal-version:       >=1.10  library   exposed-modules:     A, B-  -- other-modules:       +  -- other-modules:   other-extensions:    PatternSynonyms-  build-depends:       base >=4.7 && <4.8-  -- hs-source-dirs:      +  build-depends:       base+  -- hs-source-dirs:   default-language:    Haskell2010+  ghc-options:         -Wall+  if impl(ghc >= 8.0.1)+    ghc-options: -Wno-missing-pattern-synonym-signatures
+ test/data/quasi-quotes/FooQ.hs view
@@ -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
+ test/data/quasi-quotes/QuasiQuotes.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE QuasiQuotes #-}+module QuasiQuotes where++import FooQ++bar = [fooQ| foo bar baz |]
+ test/data/stack-project/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ test/data/stack-project/app/Main.hs view
@@ -0,0 +1,6 @@+module Main where++import Lib++main :: IO ()+main = someFunc
+ test/data/stack-project/new-template.cabal view
@@ -0,0 +1,42 @@+name:                new-template+version:             0.1.0.0+synopsis:            Initial project template from stack+description:         Please see README.md+homepage:            http://github.com/name/project+-- license:             BSD3+-- license-file:        LICENSE+author:              Your name here+maintainer:          your.address@example.com+-- copyright:+category:            Web+build-type:          Simple+-- extra-source-files:+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     Lib+  build-depends:       base+  default-language:    Haskell2010++executable new-template-exe+  hs-source-dirs:      app+  main-is:             Main.hs+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  build-depends:       base+                     , new-template+                     , bytestring+  default-language:    Haskell2010++test-suite new-template-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base+                     , new-template+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/name/project
+ test/data/stack-project/src/Lib.hs view
@@ -0,0 +1,6 @@+module Lib+    ( someFunc+    ) where++someFunc :: IO ()+someFunc = putStrLn "someFunc"
+ test/data/stack-project/stack.yaml.in view
@@ -0,0 +1,4 @@+flags: {}+packages:+- '.'+extra-deps: []
+ test/data/stack-project/test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"
− test/data/subdir1/subdir2/dummy 
@@ -1,1 +0,0 @@-dummy
+ test/data/target/Cpp.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE CPP #-}+#undef NOTHING+#ifdef NOTHING+module WRONG_MODULE where+#else+module Cpp where+#endif
+ test/data/template-haskell/Bar.hs view
@@ -0,0 +1,5 @@+{-# LANGUAGE TemplateHaskell #-}+module Bar (bar) where+import Foo (foo)++bar = $foo ++ "bar"
+ test/data/template-haskell/Foo.hs view
@@ -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
+ test/data/template-haskell/ImportsTH.hs view
@@ -0,0 +1,3 @@+import Bar (bar)++main = putStrLn bar
test/doctests.hs view
@@ -1,14 +1,23 @@+{-# LANGUAGE CPP #-} module Main where  import Test.DocTest+import System.Environment+import Data.Maybe  main :: IO ()-main = doctest [-    "-package"-  , "ghc"-  , "-XConstraintKinds", "-XFlexibleContexts"-  , "-idist/build/autogen/"-  , "-optP-include"-  , "-optPdist/build/autogen/cabal_macros.h"-  , "Language/Haskell/GhcMod.hs"-  ]+main = do+  distdir <- (fromMaybe "dist" . lookup "DOCTEST_DIST_DIR") `fmap` getEnvironment+  doctest+     [ "-package", "ghc-" ++ VERSION_ghc+     , "-package", "transformers-" ++ VERSION_transformers+     , "-package", "mtl-" ++ VERSION_mtl+     , "-package", "directory-" ++ VERSION_directory+     , "-XScopedTypeVariables", "-XRecordWildCards", "-XNamedFieldPuns", "-XConstraintKinds", "-XFlexibleContexts", "-XDataKinds", "-XKindSignatures", "-XTypeOperators", "-XViewPatterns"+     , "-i" ++ distdir ++ "/build/autogen/"+     , "-icore/"+     , "-ishared"+--     , "-optP-include"+--     , "-optP" ++ distdir ++ "/build/autogen/cabal_macros.h"+     , "GhcMod.hs"+     ]