ghc-mod-5.8.0.0/0000755000000000000000000000000013112432356011366 5ustar0000000000000000ghc-mod-5.8.0.0/GhcMod.hs0000644000000000000000000000300513112432356013061 0ustar0000000000000000-- | 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 ghc-mod-5.8.0.0/COPYING.BSD30000644000000000000000000000276513112432356013125 0ustar0000000000000000Copyright (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. ghc-mod-5.8.0.0/COPYING.AGPL30000644000000000000000000010333013112432356013226 0ustar0000000000000000 GNU AFFERO GENERAL PUBLIC LICENSE Version 3, 19 November 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The GNU Affero General Public License is a free, copyleft license for software and other kinds of works, specifically designed to ensure cooperation with the community in the case of network server software. The licenses for most software and other practical works are designed to take away your freedom to share and change the works. By contrast, our General Public Licenses are intended to guarantee your freedom to share and change all versions of a program--to make sure it remains free software for all its users. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for them if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs, and that you know you can do these things. Developers that use our General Public Licenses protect your rights with two steps: (1) assert copyright on the software, and (2) offer you this License which gives you legal permission to copy, distribute and/or modify the software. A secondary benefit of defending all users' freedom is that improvements made in alternate versions of the program, if they receive widespread use, become available for other developers to incorporate. Many developers of free software are heartened and encouraged by the resulting cooperation. However, in the case of software used on network servers, this result may fail to come about. The GNU General Public License permits making a modified version and letting the public access it on a server without ever releasing its source code to the public. The GNU Affero General Public License is designed specifically to ensure that, in such cases, the modified source code becomes available to the community. It requires the operator of a network server to provide the source code of the modified version running there to the users of that server. Therefore, public use of a modified version, on a publicly accessible server, gives the public access to the source code of the modified version. An older license, called the Affero General Public License and published by Affero, was designed to accomplish similar goals. This is a different license, not a version of the Affero GPL, but Affero has released a new version of the Affero GPL which permits relicensing under this license. The precise terms and conditions for copying, distribution and modification follow. TERMS AND CONDITIONS 0. Definitions. "This License" refers to version 3 of the GNU Affero General Public License. "Copyright" also means copyright-like laws that apply to other kinds of works, such as semiconductor masks. "The Program" refers to any copyrightable work licensed under this License. Each licensee is addressed as "you". "Licensees" and "recipients" may be individuals or organizations. To "modify" a work means to copy from or adapt all or part of the work in a fashion requiring copyright permission, other than the making of an exact copy. The resulting work is called a "modified version" of the earlier work or a work "based on" the earlier work. A "covered work" means either the unmodified Program or a work based on the Program. To "propagate" a work means to do anything with it that, without permission, would make you directly or secondarily liable for infringement under applicable copyright law, except executing it on a computer or modifying a private copy. Propagation includes copying, distribution (with or without modification), making available to the public, and in some countries other activities as well. To "convey" a work means any kind of propagation that enables other parties to make or receive copies. Mere interaction with a user through a computer network, with no transfer of a copy, is not conveying. An interactive user interface displays "Appropriate Legal Notices" to the extent that it includes a convenient and prominently visible feature that (1) displays an appropriate copyright notice, and (2) tells the user that there is no warranty for the work (except to the extent that warranties are provided), that licensees may convey the work under this License, and how to view a copy of this License. If the interface presents a list of user commands or options, such as a menu, a prominent item in the list meets this criterion. 1. Source Code. The "source code" for a work means the preferred form of the work for making modifications to it. "Object code" means any non-source form of a work. A "Standard Interface" means an interface that either is an official standard defined by a recognized standards body, or, in the case of interfaces specified for a particular programming language, one that is widely used among developers working in that language. The "System Libraries" of an executable work include anything, other than the work as a whole, that (a) is included in the normal form of packaging a Major Component, but which is not part of that Major Component, and (b) serves only to enable use of the work with that Major Component, or to implement a Standard Interface for which an implementation is available to the public in source code form. A "Major Component", in this context, means a major essential component (kernel, window system, and so on) of the specific operating system (if any) on which the executable work runs, or a compiler used to produce the work, or an object code interpreter used to run it. The "Corresponding Source" for a work in object code form means all the source code needed to generate, install, and (for an executable work) run the object code and to modify the work, including scripts to control those activities. However, it does not include the work's System Libraries, or general-purpose tools or generally available free programs which are used unmodified in performing those activities but which are not part of the work. For example, Corresponding Source includes interface definition files associated with source files for the work, and the source code for shared libraries and dynamically linked subprograms that the work is specifically designed to require, such as by intimate data communication or control flow between those subprograms and other parts of the work. The Corresponding Source need not include anything that users can regenerate automatically from other parts of the Corresponding Source. The Corresponding Source for a work in source code form is that same work. 2. Basic Permissions. All rights granted under this License are granted for the term of copyright on the Program, and are irrevocable provided the stated conditions are met. This License explicitly affirms your unlimited permission to run the unmodified Program. The output from running a covered work is covered by this License only if the output, given its content, constitutes a covered work. This License acknowledges your rights of fair use or other equivalent, as provided by copyright law. You may make, run and propagate covered works that you do not convey, without conditions so long as your license otherwise remains in force. You may convey covered works to others for the sole purpose of having them make modifications exclusively for you, or provide you with facilities for running those works, provided that you comply with the terms of this License in conveying all material for which you do not control copyright. Those thus making or running the covered works for you must do so exclusively on your behalf, under your direction and control, on terms that prohibit them from making any copies of your copyrighted material outside their relationship with you. Conveying under any other circumstances is permitted solely under the conditions stated below. Sublicensing is not allowed; section 10 makes it unnecessary. 3. Protecting Users' Legal Rights From Anti-Circumvention Law. No covered work shall be deemed part of an effective technological measure under any applicable law fulfilling obligations under article 11 of the WIPO copyright treaty adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention of such measures. When you convey a covered work, you waive any legal power to forbid circumvention of technological measures to the extent such circumvention is effected by exercising rights under this License with respect to the covered work, and you disclaim any intention to limit operation or modification of the work as a means of enforcing, against the work's users, your or third parties' legal rights to forbid circumvention of technological measures. 4. Conveying Verbatim Copies. You may convey verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice; keep intact all notices stating that this License and any non-permissive terms added in accord with section 7 apply to the code; keep intact all notices of the absence of any warranty; and give all recipients a copy of this License along with the Program. You may charge any price or no price for each copy that you convey, and you may offer support or warranty protection for a fee. 5. Conveying Modified Source Versions. You may convey a work based on the Program, or the modifications to produce it from the Program, in the form of source code under the terms of section 4, provided that you also meet all of these conditions: a) The work must carry prominent notices stating that you modified it, and giving a relevant date. b) The work must carry prominent notices stating that it is released under this License and any conditions added under section 7. This requirement modifies the requirement in section 4 to "keep intact all notices". c) You must license the entire work, as a whole, under this License to anyone who comes into possession of a copy. This License will therefore apply, along with any applicable section 7 additional terms, to the whole of the work, and all its parts, regardless of how they are packaged. This License gives no permission to license the work in any other way, but it does not invalidate such permission if you have separately received it. d) If the work has interactive user interfaces, each must display Appropriate Legal Notices; however, if the Program has interactive interfaces that do not display Appropriate Legal Notices, your work need not make them do so. A compilation of a covered work with other separate and independent works, which are not by their nature extensions of the covered work, and which are not combined with it such as to form a larger program, in or on a volume of a storage or distribution medium, is called an "aggregate" if the compilation and its resulting copyright are not used to limit the access or legal rights of the compilation's users beyond what the individual works permit. Inclusion of a covered work in an aggregate does not cause this License to apply to the other parts of the aggregate. 6. Conveying Non-Source Forms. You may convey a covered work in object code form under the terms of sections 4 and 5, provided that you also convey the machine-readable Corresponding Source under the terms of this License, in one of these ways: a) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by the Corresponding Source fixed on a durable physical medium customarily used for software interchange. b) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by a written offer, valid for at least three years and valid for as long as you offer spare parts or customer support for that product model, to give anyone who possesses the object code either (1) a copy of the Corresponding Source for all the software in the product that is covered by this License, on a durable physical medium customarily used for software interchange, for a price no more than your reasonable cost of physically performing this conveying of source, or (2) access to copy the Corresponding Source from a network server at no charge. c) Convey individual copies of the object code with a copy of the written offer to provide the Corresponding Source. This alternative is allowed only occasionally and noncommercially, and only if you received the object code with such an offer, in accord with subsection 6b. d) Convey the object code by offering access from a designated place (gratis or for a charge), and offer equivalent access to the Corresponding Source in the same way through the same place at no further charge. You need not require recipients to copy the Corresponding Source along with the object code. If the place to copy the object code is a network server, the Corresponding Source may be on a different server (operated by you or a third party) that supports equivalent copying facilities, provided you maintain clear directions next to the object code saying where to find the Corresponding Source. Regardless of what server hosts the Corresponding Source, you remain obligated to ensure that it is available for as long as needed to satisfy these requirements. e) Convey the object code using peer-to-peer transmission, provided you inform other peers where the object code and Corresponding Source of the work are being offered to the general public at no charge under subsection 6d. A separable portion of the object code, whose source code is excluded from the Corresponding Source as a System Library, need not be included in conveying the object code work. A "User Product" is either (1) a "consumer product", which means any tangible personal property which is normally used for personal, family, or household purposes, or (2) anything designed or sold for incorporation into a dwelling. In determining whether a product is a consumer product, doubtful cases shall be resolved in favor of coverage. For a particular product received by a particular user, "normally used" refers to a typical or common use of that class of product, regardless of the status of the particular user or of the way in which the particular user actually uses, or expects or is expected to use, the product. A product is a consumer product regardless of whether the product has substantial commercial, industrial or non-consumer uses, unless such uses represent the only significant mode of use of the product. "Installation Information" for a User Product means any methods, procedures, authorization keys, or other information required to install and execute modified versions of a covered work in that User Product from a modified version of its Corresponding Source. The information must suffice to ensure that the continued functioning of the modified object code is in no case prevented or interfered with solely because modification has been made. If you convey an object code work under this section in, or with, or specifically for use in, a User Product, and the conveying occurs as part of a transaction in which the right of possession and use of the User Product is transferred to the recipient in perpetuity or for a fixed term (regardless of how the transaction is characterized), the Corresponding Source conveyed under this section must be accompanied by the Installation Information. But this requirement does not apply if neither you nor any third party retains the ability to install modified object code on the User Product (for example, the work has been installed in ROM). The requirement to provide Installation Information does not include a requirement to continue to provide support service, warranty, or updates for a work that has been modified or installed by the recipient, or for the User Product in which it has been modified or installed. Access to a network may be denied when the modification itself materially and adversely affects the operation of the network or violates the rules and protocols for communication across the network. Corresponding Source conveyed, and Installation Information provided, in accord with this section must be in a format that is publicly documented (and with an implementation available to the public in source code form), and must require no special password or key for unpacking, reading or copying. 7. Additional Terms. "Additional permissions" are terms that supplement the terms of this License by making exceptions from one or more of its conditions. Additional permissions that are applicable to the entire Program shall be treated as though they were included in this License, to the extent that they are valid under applicable law. If additional permissions apply only to part of the Program, that part may be used separately under those permissions, but the entire Program remains governed by this License without regard to the additional permissions. When you convey a copy of a covered work, you may at your option remove any additional permissions from that copy, or from any part of it. (Additional permissions may be written to require their own removal in certain cases when you modify the work.) You may place additional permissions on material, added by you to a covered work, for which you have or can give appropriate copyright permission. Notwithstanding any other provision of this License, for material you add to a covered work, you may (if authorized by the copyright holders of that material) supplement the terms of this License with terms: a) Disclaiming warranty or limiting liability differently from the terms of sections 15 and 16 of this License; or b) Requiring preservation of specified reasonable legal notices or author attributions in that material or in the Appropriate Legal Notices displayed by works containing it; or c) Prohibiting misrepresentation of the origin of that material, or requiring that modified versions of such material be marked in reasonable ways as different from the original version; or d) Limiting the use for publicity purposes of names of licensors or authors of the material; or e) Declining to grant rights under trademark law for use of some trade names, trademarks, or service marks; or f) Requiring indemnification of licensors and authors of that material by anyone who conveys the material (or modified versions of it) with contractual assumptions of liability to the recipient, for any liability that these contractual assumptions directly impose on those licensors and authors. All other non-permissive additional terms are considered "further restrictions" within the meaning of section 10. If the Program as you received it, or any part of it, contains a notice stating that it is governed by this License along with a term that is a further restriction, you may remove that term. If a license document contains a further restriction but permits relicensing or conveying under this License, you may add to a covered work material governed by the terms of that license document, provided that the further restriction does not survive such relicensing or conveying. If you add terms to a covered work in accord with this section, you must place, in the relevant source files, a statement of the additional terms that apply to those files, or a notice indicating where to find the applicable terms. Additional terms, permissive or non-permissive, may be stated in the form of a separately written license, or stated as exceptions; the above requirements apply either way. 8. Termination. You may not propagate or modify a covered work except as expressly provided under this License. Any attempt otherwise to propagate or modify it is void, and will automatically terminate your rights under this License (including any patent licenses granted under the third paragraph of section 11). However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation. Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice. Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, you do not qualify to receive new licenses for the same material under section 10. 9. Acceptance Not Required for Having Copies. You are not required to accept this License in order to receive or run a copy of the Program. Ancillary propagation of a covered work occurring solely as a consequence of using peer-to-peer transmission to receive a copy likewise does not require acceptance. However, nothing other than this License grants you permission to propagate or modify any covered work. These actions infringe copyright if you do not accept this License. Therefore, by modifying or propagating a covered work, you indicate your acceptance of this License to do so. 10. Automatic Licensing of Downstream Recipients. Each time you convey a covered work, the recipient automatically receives a license from the original licensors, to run, modify and propagate that work, subject to this License. You are not responsible for enforcing compliance by third parties with this License. An "entity transaction" is a transaction transferring control of an organization, or substantially all assets of one, or subdividing an organization, or merging organizations. If propagation of a covered work results from an entity transaction, each party to that transaction who receives a copy of the work also receives whatever licenses to the work the party's predecessor in interest had or could give under the previous paragraph, plus a right to possession of the Corresponding Source of the work from the predecessor in interest, if the predecessor has it or can get it with reasonable efforts. You may not impose any further restrictions on the exercise of the rights granted or affirmed under this License. For example, you may not impose a license fee, royalty, or other charge for exercise of rights granted under this License, and you may not initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging that any patent claim is infringed by making, using, selling, offering for sale, or importing the Program or any portion of it. 11. Patents. A "contributor" is a copyright holder who authorizes use under this License of the Program or a work on which the Program is based. The work thus licensed is called the contributor's "contributor version". A contributor's "essential patent claims" are all patent claims owned or controlled by the contributor, whether already acquired or hereafter acquired, that would be infringed by some manner, permitted by this License, of making, using, or selling its contributor version, but do not include claims that would be infringed only as a consequence of further modification of the contributor version. For purposes of this definition, "control" includes the right to grant patent sublicenses in a manner consistent with the requirements of this License. Each contributor grants you a non-exclusive, worldwide, royalty-free patent license under the contributor's essential patent claims, to make, use, sell, offer for sale, import and otherwise run, modify and propagate the contents of its contributor version. In the following three paragraphs, a "patent license" is any express agreement or commitment, however denominated, not to enforce a patent (such as an express permission to practice a patent or covenant not to sue for patent infringement). To "grant" such a patent license to a party means to make such an agreement or commitment not to enforce a patent against the party. If you convey a covered work, knowingly relying on a patent license, and the Corresponding Source of the work is not available for anyone to copy, free of charge and under the terms of this License, through a publicly available network server or other readily accessible means, then you must either (1) cause the Corresponding Source to be so available, or (2) arrange to deprive yourself of the benefit of the patent license for this particular work, or (3) arrange, in a manner consistent with the requirements of this License, to extend the patent license to downstream recipients. "Knowingly relying" means you have actual knowledge that, but for the patent license, your conveying the covered work in a country, or your recipient's use of the covered work in a country, would infringe one or more identifiable patents in that country that you have reason to believe are valid. If, pursuant to or in connection with a single transaction or arrangement, you convey, or propagate by procuring conveyance of, a covered work, and grant a patent license to some of the parties receiving the covered work authorizing them to use, propagate, modify or convey a specific copy of the covered work, then the patent license you grant is automatically extended to all recipients of the covered work and works based on it. A patent license is "discriminatory" if it does not include within the scope of its coverage, prohibits the exercise of, or is conditioned on the non-exercise of one or more of the rights that are specifically granted under this License. You may not convey a covered work if you are a party to an arrangement with a third party that is in the business of distributing software, under which you make payment to the third party based on the extent of your activity of conveying the work, and under which the third party grants, to any of the parties who would receive the covered work from you, a discriminatory patent license (a) in connection with copies of the covered work conveyed by you (or copies made from those copies), or (b) primarily for and in connection with specific products or compilations that contain the covered work, unless you entered into that arrangement, or that patent license was granted, prior to 28 March 2007. Nothing in this License shall be construed as excluding or limiting any implied license or other defenses to infringement that may otherwise be available to you under applicable patent law. 12. No Surrender of Others' Freedom. If conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot convey a covered work so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not convey it at all. For example, if you agree to terms that obligate you to collect a royalty for further conveying from those to whom you convey the Program, the only way you could satisfy both those terms and this License would be to refrain entirely from conveying the Program. 13. Remote Network Interaction; Use with the GNU General Public License. Notwithstanding any other provision of this License, if you modify the Program, your modified version must prominently offer all users interacting with it remotely through a computer network (if your version supports such interaction) an opportunity to receive the Corresponding Source of your version by providing access to the Corresponding Source from a network server at no charge, through some standard or customary means of facilitating copying of software. This Corresponding Source shall include the Corresponding Source for any work covered by version 3 of the GNU General Public License that is incorporated pursuant to the following paragraph. Notwithstanding any other provision of this License, you have permission to link or combine any covered work with a work licensed under version 3 of the GNU General Public License into a single combined work, and to convey the resulting work. The terms of this License will continue to apply to the part which is the covered work, but the work with which it is combined will remain governed by version 3 of the GNU General Public License. 14. Revised Versions of this License. The Free Software Foundation may publish revised and/or new versions of the GNU Affero General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies that a certain numbered version of the GNU Affero General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that numbered version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the GNU Affero General Public License, you may choose any version ever published by the Free Software Foundation. If the Program specifies that a proxy can decide which future versions of the GNU Affero General Public License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Program. Later license versions may give you additional or different permissions. However, no additional obligations are imposed on any author or copyright holder as a result of your choosing to follow a later version. 15. Disclaimer of Warranty. THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. Limitation of Liability. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 17. Interpretation of Sections 15 and 16. If the disclaimer of warranty and limitation of liability provided above cannot be given local legal effect according to their terms, reviewing courts shall apply local law that most closely approximates an absolute waiver of all civil liability in connection with the Program, unless a warranty or assumption of liability accompanies a copy of the Program in return for a fee. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively state the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software: you can redistribute it and/or modify it under the terms of the GNU Affero General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more details. You should have received a copy of the GNU Affero General Public License along with this program. If not, see . Also add information on how to contact you by electronic and paper mail. If your software can interact with users remotely through a computer network, you should also make sure that it provides a way for users to get its source. For example, if your program is a web application, its interface could display a "Source" link that leads users to an archive of the code. There are many ways you could offer source, and different solutions will be better for different programs; see section 13 for the specific requirements. You should also get your employer (if you work as a programmer) or school, if any, to sign a "copyright disclaimer" for the program, if necessary. For more information on this, and how to apply and follow the GNU AGPL, see . ghc-mod-5.8.0.0/Setup.hs0000644000000000000000000000751613112432356013033 0ustar0000000000000000#!/usr/bin/env runhaskell {-# LANGUAGE RecordWildCards, NamedFieldPuns #-} import Distribution.Simple 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 } ghc-mod-5.8.0.0/ghc-mod.cabal0000644000000000000000000004050713112432356013676 0ustar0000000000000000Name: ghc-mod Version: 5.8.0.0 Author: Kazu Yamamoto , Daniel Gröber , Alejandro Serrano , Nikolay Yakimov Maintainer: Daniel Gröber License: AGPL-3 License-File: LICENSE 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. 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 README.md core/GhcMod/Monad/Compat.hs_h test/data/annotations/*.hs test/data/broken-cabal/*.cabal test/data/broken-sandbox/cabal.sandbox.config test/data/broken-sandbox/dummy.cabal test/data/cabal-flags/cabal-flags.cabal test/data/cabal-project/*.cabal test/data/cabal-project/*.hs test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf test/data/cabal-project/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/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/foreign-export/*.hs test/data/ghc-mod-check/*.cabal test/data/ghc-mod-check/*.hs 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 -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 , mtl , old-time , process , template-haskell , time , transformers , 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: GhcModMain.hs Other-Modules: Paths_ghc_mod , 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, shared X-Internal: True Build-Depends: -- See Note [GHC Boot libraries] directory , filepath , 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 Other-Modules: Paths_ghc_mod Utils System.Directory.ModTime GHC-Options: -Wall -threaded -fno-warn-deprecations if os(windows) Cpp-Options: -DWINDOWS Default-Extensions: ConstraintKinds, FlexibleContexts HS-Source-Dirs: ., src, shared Build-Depends: -- See Note [GHC Boot libraries] binary , deepseq , directory , filepath , old-time , process , time , base < 4.10 && >= 4.6.0.1 , ghc-mod Test-Suite doctest Type: exitcode-stdio-1.0 Default-Language: Haskell2010 HS-Source-Dirs: test Ghc-Options: -Wall Default-Extensions: ConstraintKinds, FlexibleContexts Main-Is: doctests.hs Build-Depends: base < 4.10 && >= 4.6.0.1 , doctest < 0.12 && >= 0.9.3 Test-Suite spec Default-Language: Haskell2010 Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns, ConstraintKinds, FlexibleContexts, DataKinds, KindSignatures, TypeOperators, ViewPatterns Main-Is: Main.hs Hs-Source-Dirs: test, src Ghc-Options: -Wall -fno-warn-deprecations -threaded Type: exitcode-stdio-1.0 Other-Modules: Paths_ghc_mod Dir TestUtils -- $ ls test/*Spec.hs | sed 's_^.*/\(.*\)\.hs$_\1_' | sort BrowseSpec CabalHelperSpec CaseSplitSpec CheckSpec CradleSpec CustomPackageDbSpec FileMappingSpec FindSpec FlagSpec GhcPkgSpec HomeModuleGraphSpec InfoSpec LangSpec LintSpec ListSpec MonadSpec PathsAndFilesSpec ShellParseSpec TargetSpec Build-Depends: -- See Note [GHC Boot libraries] containers , directory , filepath , mtl , process , transformers , 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: 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. ghc-mod-5.8.0.0/ChangeLog0000644000000000000000000002505213112432356013144 0ustar00000000000000002017-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 2014-09-16 v5.1.0.1 * 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 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 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` 2014-08-20 v5.0.1 * Fix missing file in "Data-Files" 2014-08-20 v5.0.0 * ghc-mod consumes much less memory than ghc-mod-4.1. * @serras brought the results of Google Summer code including case splitting and better type hole * @DanielG provided the new monad based API 2014-05-16 v4.1.6 * Reverting "Trying to fix rare hang on Nix". 2014-05-16 v4.1.5 * Fixing the build on GHC 7.8.3. 2014-05-16 v4.1.4 * Trying to fix rare hang on Nix. 2014-05-16 v4.1.3 * Making -g-fxxx work. 2014-05-16 v4.1.2 * Setting Opt_WarnTypedHoles correctly. 2014-05-16 v4.1.1 * Making Emacs front-end more stable. 2014-04-30 v4.1.0 * ghc-modi now provides "type", "info", and "boot". * ghc-mod now provides "find". * Packages, which are specified in a cabal file but not installed, are filtered out. (@DanielG) * ghc-mod/ghc-modi treats "-l" properly. * ghc-mod obsoletes "-p". Use "ghc-mod browse package:module". * M-x ghc-debug has been implemented. * "type" and "info" can work even if files contain type errors. * "boot" as a new API. 2014-04-07 v4.0.2 * The ghc-display-error option (@notogawa) * Fixing a file bug for Windows (@Kiripon) * The -b option for ghc-modi (@yuga) 2014-04-03 v4.0.1 * Displaying a qualified name for one if two unqualified names are conflict. 2014-04-01 v4.0.0 * Implementing interactive "ghc-modi" command. "check", "find", and "lint" are available. * Introducing a concept of project root directory. Thanks to this, sandbox without cabal can be used. "ghd-mod debug" displays the project root. * Syntax error highlighting (C-xC-s) gets much faster thanks to ghc-modi. "flymake" was thrown away and syntax error highlighting is implemented from a scratch. * Resolving the "import hell". You dont' have to type "import Foo" anymore. Use M-t or C-cC-m. * Inserting "module Foo" (M-t) can insert all paths relative to the project root. * M-C-d displays a html document even if it is in its sandbox. * M-s now merges the same module lines in addition to sorting. * A bug fix for hlint support. (@eagletmt) 2014-03-15 v3.1.7 * Defining ghc-debug for Elisp debugging. * Catching up the latest hlint which does not provide --quite. 2014-02-07 v3.1.6 * Testing with multi GHC versions. (@eagletmt) * Checking package ID. (@naota) * Supporting GHC 7.8.1 RC1. (@bartavelle) 2014-01-14 v3.1.5 * Catching up to GHC 7.7. (@scottgw) * Testing with multi GHC versions. (@eagletmt) * Workaround for the coming new Haskell Platform. * Supporting flymake of the coming Emacs 24.4. 2013-11-20 v3.1.4 * GHCi loading as fallback for browse. (@khorser) * Supporting GHC 7.7. (@schell) * Introducing the "-p" and "-q" option for browse. (@mvoidex) 2013-10-07 v3.1.3 * Fixing tests. (@eagletmt) 2013-09-21 v3.1.2 * Supporting sandbox for "list" and "browse". (@eagletmt) 2013-09-21 v3.1.1 * Making Cradle strict. 2013-09-21 v3.1.0 * API breaks backward compatibility. * Supporting sandbox sharing. 2013-09-16 v3.0.2 * Fixing a bug of "dist/build/autogen/cabal_macros.h". 2013-09-16 v3.0.1 * Exporting more low level APIs. * Adding "-ibuild/autogen" * Adding "-optP". (Macros from a Cabal file and "dist/build/autogen/cabal_macros.h") 2013-09-06 v3.0.0 * Supporting the sandbox of cabal 1.18. * Obsoleting the support for cabal-dev. 2013-09-04 v2.1.2 * Supporting multiple target files. (@nh2) 2013-09-03 v2.1.1 * A bug fix for library dependency. 2013-09-03 v2.1.0 * Exporting Language.Haskell.GhcMod.Internal. (@alanz) * Supporting GHC 7.7. (@co-dan) 2013-05-30 v2.0.3 * Using finalizePackageDescription to enable "if else" in a cabal file. 2013-05-21 v2.0.2 * Document fixes. 2013-05-21 v2.0.1 * Document fixes. 2013-05-21 v2.0.0 * ghc-mod also provides a library (Language.Haskell.GhcMod) 2013-05-13 v1.12.5 * A bug fix for the case where a cabal file is broken. 2013-04-02 v1.12.4 * C-M-d on Emacs now can browse functions and types. * Checking "QuasiQuotes" as well as "TemplateHaskell". (@eagletmt) * "ghc-mod info" can display info of non-exported functions. (@mvoidex) 2013-03-16 v1.12.3 * "ghc-mod info" and "ghc-mod type" also check Template Haskell. (@eagletmt) 2013-03-13 v1.12.2 * New logic to set "-fno-code" using "depanal" * Cleaning up the code relating to Doc/SDoc 2013-03-07 v1.12.1 * Fixing a bug to find a sandbox. 2013-03-05 v1.12.0 * "ghc-mod debug" to see which cabal file and sand box are used * Fast "ghc-mod check" if Template Haskell is not used * "ghc-mod brwose -d" displays more information (@eagletmt) 2013-03-01 v1.11.5 * New option "-d" for "ghc-mod browse" to show symbols with type info (@moidex) 2013-02-15 v1.11.4 * Adding Hspec test suite * Better way to show Extension (@eagletmt) * Removing the library itself from Cabal dependencies 2012-12-11 v1.11.3 * Display a filname instead of "Dummy" if an error occur 2012-10-30 v1.11.2 * Extract dependencies from a Cabal file if exists and specify them to "ghc-mod check" (@khibino) 2012-10-19 v1.11.1 * Supporting GHC 7.6.x (@cartazio, @dysinger, @ihameed) ghc-mod-5.8.0.0/README.md0000644000000000000000000001154613112432356012654 0ustar0000000000000000# 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. ghc-mod-5.8.0.0/GhcMod/0000755000000000000000000000000013112432356012527 5ustar0000000000000000ghc-mod-5.8.0.0/GhcMod/Exe/0000755000000000000000000000000013112432356013250 5ustar0000000000000000ghc-mod-5.8.0.0/GhcMod/Exe/Boot.hs0000644000000000000000000000124313112432356014507 0ustar0000000000000000module 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" ] ghc-mod-5.8.0.0/GhcMod/Exe/Browse.hs0000644000000000000000000001316013112432356015046 0ustar0000000000000000{-# 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 ghc-mod-5.8.0.0/GhcMod/Exe/CaseSplit.hs0000644000000000000000000002566213112432356015506 0ustar0000000000000000{-# 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 ghc-mod-5.8.0.0/GhcMod/Exe/Check.hs0000644000000000000000000000311213112432356014616 0ustar0000000000000000module 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 ()) ghc-mod-5.8.0.0/GhcMod/Exe/Debug.hs0000644000000000000000000001377513112432356014647 0ustar0000000000000000module 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" ghc-mod-5.8.0.0/GhcMod/Exe/FillSig.hs0000644000000000000000000005557413112432356015155 0ustar0000000000000000{-# 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) ghc-mod-5.8.0.0/GhcMod/Exe/Find.hs0000644000000000000000000001455113112432356014472 0ustar0000000000000000{-# 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 ghc-mod-5.8.0.0/GhcMod/Exe/Flag.hs0000644000000000000000000000040513112432356014454 0ustar0000000000000000module 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 ghc-mod-5.8.0.0/GhcMod/Exe/Info.hs0000644000000000000000000000473213112432356014505 0ustar0000000000000000module 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) ghc-mod-5.8.0.0/GhcMod/Exe/Internal.hs0000644000000000000000000000255713112432356015371 0ustar0000000000000000-- | 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 ghc-mod-5.8.0.0/GhcMod/Exe/Lang.hs0000644000000000000000000000037413112432356014471 0ustar0000000000000000module 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 ghc-mod-5.8.0.0/GhcMod/Exe/Lint.hs0000644000000000000000000000203513112432356014512 0ustar0000000000000000module 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 ghc-mod-5.8.0.0/GhcMod/Exe/Modules.hs0000644000000000000000000000161613112432356015220 0ustar0000000000000000module 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 ghc-mod-5.8.0.0/GhcMod/Exe/PkgDoc.hs0000644000000000000000000000163613112432356014761 0ustar0000000000000000module 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") ghc-mod-5.8.0.0/GhcMod/Exe/Test.hs0000644000000000000000000000223713112432356014527 0ustar0000000000000000module 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" ghc-mod-5.8.0.0/core/0000755000000000000000000000000013112432356012316 5ustar0000000000000000ghc-mod-5.8.0.0/core/GhcMod/0000755000000000000000000000000013112432356013457 5ustar0000000000000000ghc-mod-5.8.0.0/core/GhcMod/CabalHelper.hs0000644000000000000000000002603113112432356016157 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE CPP #-} module GhcMod.CabalHelper ( getComponents , getGhcMergedPkgOptions , getCabalPackageDbStack , prepareCabalHelper , withAutogen , withCabal ) where import Control.Applicative import Control.Monad import Control.Category ((.)) import Data.Maybe import Data.Monoid import Data.Version import Data.Binary (Binary) import Data.Traversable import Distribution.Helper hiding (Programs(..)) import qualified Distribution.Helper as CH import qualified GhcMod.Types as T import GhcMod.Types import GhcMod.Monad.Types import GhcMod.Utils import GhcMod.PathsAndFiles import GhcMod.Logging import GhcMod.Output import GhcMod.CustomPackageDb import GhcMod.Stack import System.FilePath import System.Process import System.Exit import Prelude hiding ((.)) import Paths_ghc_mod as GhcMod -- | Only package related GHC options, sufficient for things that don't need to -- access home modules getGhcMergedPkgOptions :: (Applicative m, IOish m, Gm m) => m [GHCOption] getGhcMergedPkgOptions = chCached $ \distdir -> Cached { cacheLens = Just (lGmcMergedPkgOptions . lGmCaches), cacheFile = mergedPkgOptsCacheFile distdir, cachedAction = \_tcf (_progs, _projdir, _ver) _ma -> do opts <- runCHQuery ghcMergedPkgOptions return ([setupConfigPath distdir], opts) } getCabalPackageDbStack :: (IOish m, Gm m) => m [GhcPkgDb] getCabalPackageDbStack = chCached $ \distdir -> Cached { cacheLens = Just (lGmcPackageDbStack . lGmCaches), cacheFile = pkgDbStackCacheFile distdir, cachedAction = \_tcf (_progs, _projdir, _ver) _ma -> do crdl <- cradle dbs <- map chPkgToGhcPkg <$> runCHQuery packageDbStack return ([setupConfigFile crdl, sandboxConfigFile crdl], dbs) } chPkgToGhcPkg :: ChPkgDb -> GhcPkgDb chPkgToGhcPkg ChPkgGlobal = GlobalDb chPkgToGhcPkg ChPkgUser = UserDb chPkgToGhcPkg (ChPkgSpecific f) = PackageDb f -- | Primary interface to cabal-helper and intended single entrypoint to -- constructing 'GmComponent's -- -- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by -- 'resolveGmComponents'. getComponents :: (Applicative m, IOish m, Gm m) => m [GmComponent 'GMCRaw ChEntrypoint] getComponents = chCached $ \distdir -> Cached { cacheLens = Just (lGmcComponents . lGmCaches), cacheFile = cabalHelperCacheFile distdir, cachedAction = \ _tcf (_progs, _projdir, _ver) _ma -> do runCHQuery $ do q <- join7 <$> ghcOptions <*> ghcPkgOptions <*> ghcSrcOptions <*> ghcLangOptions <*> entrypoints <*> entrypoints <*> sourceDirs let cs = flip map q $ curry8 (GmComponent mempty) return ([setupConfigPath distdir], cs) } where curry8 fn (a, (b, (c, (d, (e, (f, (g, h))))))) = fn a b c d e f g h join7 a b c d e f = join' a . join' b . join' c . join' d . join' e . join' f join' :: Eq a => [(a,b)] -> [(a,c)] -> [(a,(b,c))] join' lb lc = [ (a, (b, c)) | (a, b) <- lb , (a', c) <- lc , a == a' ] getQueryEnv :: (IOish m, GmOut m, GmEnv m) => m QueryEnv getQueryEnv = do crdl <- cradle progs <- patchStackPrograms crdl =<< (optPrograms <$> options) readProc <- gmReadProcess let projdir = cradleRootDir crdl distdir = projdir cradleDistDir crdl return (defaultQueryEnv projdir distdir) { qeReadProcess = readProc , qePrograms = helperProgs progs } runCHQuery :: (IOish m, GmOut m, GmEnv m) => Query m b -> m b runCHQuery a = do qe <- getQueryEnv runQuery qe a prepareCabalHelper :: (IOish m, GmEnv m, GmOut m, GmLog m) => m () prepareCabalHelper = do crdl <- cradle when (isCabalHelperProject $ cradleProject crdl) $ withCabal $ prepare' =<< getQueryEnv withAutogen :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a withAutogen action = do gmLog GmDebug "" $ strDoc $ "making sure autogen files exist" crdl <- cradle let projdir = cradleRootDir crdl distdir = projdir cradleDistDir crdl (pkgName', _) <- runCHQuery packageId mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl mCabalMacroHeader <- liftIO $ timeMaybe (distdir macrosHeaderPath) mCabalPathsModule <- liftIO $ timeMaybe (distdir autogenModulePath pkgName') when (mCabalMacroHeader < mCabalFile || mCabalPathsModule < mCabalFile) $ do gmLog GmDebug "" $ strDoc $ "autogen files out of sync" writeAutogen action where writeAutogen = do gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files" writeAutogenFiles' =<< getQueryEnv withCabal :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a withCabal action = do crdl <- cradle mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl) mCabalSandboxConfig <- liftIO $ timeMaybe (sandboxConfigFile crdl) let haveSetupConfig = isJust mCabalConfig cusPkgDb <- getCustomPkgDbStack (flgs, pkgDbStackOutOfSync) <- do if haveSetupConfig then runCHQuery $ do flgs <- nonDefaultConfigFlags pkgDb <- map chPkgToGhcPkg <$> packageDbStack return (flgs, fromMaybe False $ (pkgDb /=) <$> cusPkgDb) else return ([], False) when (isSetupConfigOutOfDate mCabalFile mCabalConfig) $ gmLog GmDebug "" $ strDoc $ "setup configuration is out of date" when (isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $ gmLog GmDebug "" $ strDoc $ "sandbox configuration is out of date" when pkgDbStackOutOfSync $ gmLog GmDebug "" $ strDoc $ "package-db stack out of sync with ghc-mod.package-db-stack" when ( isSetupConfigOutOfDate mCabalFile mCabalConfig || pkgDbStackOutOfSync || isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $ do proj <- cradleProject <$> cradle opts <- options case proj of CabalProject -> do gmLog GmDebug "" $ strDoc "reconfiguring Cabal project" cabalReconfigure (optPrograms opts) crdl flgs StackProject {} -> do gmLog GmDebug "" $ strDoc "reconfiguring Stack project" -- TODO: we could support flags for stack too, but it seems -- you're supposed to put those in stack.yaml so detecting which -- flags to pass down would be more difficult -- "--flag PACKAGE:[-]FLAG Override flags set in stack.yaml -- (applies to local packages and extra-deps)" stackReconfigure (optStackBuildDeps opts) crdl (optPrograms opts) _ -> error $ "withCabal: unsupported project type: " ++ show proj action where cabalReconfigure progs crdl flgs = do readProc <- gmReadProcess withDirectory_ (cradleRootDir crdl) $ do cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack let progOpts = [ "--with-ghc=" ++ T.ghcProgram progs ] -- Only pass ghc-pkg if it was actually set otherwise we -- might break cabal's guessing logic ++ if T.ghcPkgProgram progs /= T.ghcPkgProgram (optPrograms defaultOptions) then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram progs ] else [] ++ map pkgDbArg cusPkgStack ++ flagOpt toFlag (f, True) = f toFlag (f, False) = '-':f flagOpt = ["--flags", unwords $ map toFlag flgs] liftIO $ void $ readProc (T.cabalProgram progs) ("configure":progOpts) "" stackReconfigure deps crdl progs = do withDirectory_ (cradleRootDir crdl) $ do supported <- haveStackSupport if supported then do when deps $ spawn [T.stackProgram progs, "build", "--only-dependencies", "."] spawn [T.stackProgram progs, "build", "--only-configure", "."] else gmLog GmWarning "" $ strDoc $ "Stack project configuration is out of date, please reconfigure manually using 'stack build' as your stack version is too old (need at least 0.1.4.0)" spawn [] = return () spawn (exe:args) = do readProc <- gmReadProcess liftIO $ void $ readProc exe args "" haveStackSupport = do (rv, _, _) <- liftIO $ readProcessWithExitCode "stack" ["--numeric-version"] "" case rv of ExitSuccess -> return True ExitFailure _ -> return False pkgDbArg :: GhcPkgDb -> String pkgDbArg GlobalDb = "--package-db=global" pkgDbArg UserDb = "--package-db=user" pkgDbArg (PackageDb p) = "--package-db=" ++ p -- * Neither file exists -> should return False: -- @Nothing < Nothing = False@ -- (since we don't need to @cabal configure@ when no cabal file exists.) -- -- * Cabal file doesn't exist (impossible since cabal-helper is only used with -- cabal projects) -> should return False -- @Just cc < Nothing = False@ -- -- * dist/setup-config doesn't exist yet -> should return True: -- @Nothing < Just cf = True@ -- -- * Both files exist -- @Just cc < Just cf = cc < cf = cc `olderThan` cf@ isSetupConfigOutOfDate :: Maybe TimedFile -> Maybe TimedFile -> Bool isSetupConfigOutOfDate worldCabalFile worldCabalConfig = do worldCabalConfig < worldCabalFile helperProgs :: Programs -> CH.Programs helperProgs progs = CH.Programs { cabalProgram = T.cabalProgram progs, ghcProgram = T.ghcProgram progs, ghcPkgProgram = T.ghcPkgProgram progs } chCached :: (Applicative m, IOish m, Gm m, Binary a) => (FilePath -> Cached m GhcModState ChCacheData a) -> m a chCached c = do projdir <- cradleRootDir <$> cradle distdir <- (projdir ) . cradleDistDir <$> cradle d <- cacheInputData projdir withCabal $ cached projdir (c distdir) d where -- we don't need to include the distdir in the cache input because when it -- changes the cache files will be gone anyways ;) cacheInputData projdir = do opts <- options crdl <- cradle progs' <- patchStackPrograms crdl (optPrograms opts) return $ ( helperProgs progs' , projdir , (showVersion gmVer, chVer) ) gmVer = GhcMod.version chVer = VERSION_cabal_helper ghc-mod-5.8.0.0/core/GhcMod/Caching.hs0000644000000000000000000001167113112432356015355 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE CPP, OverloadedStrings #-} module GhcMod.Caching ( module GhcMod.Caching , module GhcMod.Caching.Types ) where import Control.Arrow (first) import Control.Monad import Control.Monad.Trans.Maybe #if !MIN_VERSION_binary(0,7,0) import Control.Exception #endif import Data.Maybe import Data.Binary hiding (get) import Data.Version import Data.Label import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import System.FilePath import System.Directory.ModTime import Utils (TimedFile(..), timeMaybe, mightExist) import Paths_ghc_mod (version) import Prelude import GhcMod.Monad.Types import GhcMod.Caching.Types import GhcMod.Logging -- | Cache a MonadIO action with proper invalidation. cached :: forall m a d. (Gm m, MonadIO m, Binary a, Eq d, Binary d, Show d) => FilePath -- ^ Directory to prepend to 'cacheFile' -> Cached m GhcModState d a -- ^ Cache descriptor -> d -> m a cached dir cd d = do mcc <- readCache case mcc of Nothing -> do t <- liftIO $ getCurrentModTime writeCache (TimedCacheFiles t []) Nothing "cache missing or unreadable" Just (t, ifs, d', a) | d /= d' -> do tcfs <- timeCacheInput dir ifs writeCache (TimedCacheFiles t tcfs) (Just a) $ "input data changed" -- ++ " was: " ++ show d ++ " is: " ++ show d' Just (t, ifs, _, a) -> do tcfs <- timeCacheInput dir ifs case invalidatingInputFiles $ TimedCacheFiles t tcfs of [] -> return a _ -> writeCache (TimedCacheFiles t tcfs) (Just a) "input files changed" where cacheHeader = BS8.pack $ "Written by ghc-mod " ++ showVersion version ++ "\n" lbsToStrict = BS.concat . LBS.toChunks lbsFromStrict bs = LBS.fromChunks [bs] writeCache tcfs ma cause = do (ifs', a) <- (cachedAction cd) tcfs d ma t <- liftIO $ getCurrentModTime gmLog GmDebug "" $ (text "regenerating cache") <+>: text (cacheFile cd) <+> parens (text cause) case cacheLens cd of Nothing -> return () Just label -> do gmLog GmDebug "" $ (text "writing memory cache") <+>: text (cacheFile cd) setLabel label $ Just (t, ifs', d, a) let c = BS.append cacheHeader $ lbsToStrict $ encode (t, ifs', d, a) liftIO $ BS.writeFile (dir cacheFile cd) c return a setLabel l x = do s <- gmsGet gmsPut $ set l x s readCache :: m (Maybe (ModTime, [FilePath], d, a)) readCache = runMaybeT $ do case cacheLens cd of Just label -> do c <- MaybeT (get label `liftM` gmsGet) `mplus` readCacheFromFile setLabel label $ Just c return c Nothing -> readCacheFromFile readCacheFromFile :: MaybeT m (ModTime, [FilePath], d, a) readCacheFromFile = do f <- MaybeT $ liftIO $ mightExist $ cacheFile cd readCacheFromFile' f readCacheFromFile' :: FilePath -> MaybeT m (ModTime, [FilePath], d, a) readCacheFromFile' f = MaybeT $ do gmLog GmDebug "" $ (text "reading cache") <+>: text (cacheFile cd) cc <- liftIO $ BS.readFile f case first BS8.words $ BS8.span (/='\n') cc of (["Written", "by", "ghc-mod", ver], rest) | BS8.unpack ver == showVersion version -> either (const Nothing) Just `liftM` decodeE (lbsFromStrict $ BS.drop 1 rest) _ -> return Nothing decodeE b = do #if MIN_VERSION_binary(0,7,0) return $ case decodeOrFail b of Left (_rest, _offset, errmsg) -> Left errmsg Right (_reset, _offset, a) -> Right a #else ea <- liftIO $ try $ evaluate $ decode b return $ case ea of Left (ErrorCall errmsg) -> Left errmsg Right a -> Right a #endif timeCacheInput :: MonadIO m => FilePath -> [FilePath] -> m [TimedFile] timeCacheInput dir ifs = liftIO $ do ins <- (timeMaybe . (dir )) `mapM` ifs return $ catMaybes ins invalidatingInputFiles :: TimedCacheFiles -> [FilePath] invalidatingInputFiles (TimedCacheFiles tcreated tcfs) = map tfPath $ -- get input files older than tcfile filter ((TimedFile "" tcreated)<) tcfs ghc-mod-5.8.0.0/core/GhcMod/Convert.hs0000644000000000000000000001150513112432356015435 0ustar0000000000000000{-# 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 ghc-mod-5.8.0.0/core/GhcMod/Cradle.hs0000644000000000000000000001414213112432356015207 0ustar0000000000000000{-# 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" } ghc-mod-5.8.0.0/core/GhcMod/CustomPackageDb.hs0000644000000000000000000000274013112432356017012 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . module GhcMod.CustomPackageDb where import Control.Applicative import Control.Monad import Control.Category ((.)) import Data.Maybe import Data.Traversable import GhcMod.Types import GhcMod.Monad.Types import GhcMod.PathsAndFiles import Prelude hiding ((.)) parseCustomPackageDb :: String -> [GhcPkgDb] parseCustomPackageDb src = map parsePkgDb $ filter (not . null) $ lines src where parsePkgDb "global" = GlobalDb parsePkgDb "user" = UserDb parsePkgDb s = PackageDb s getCustomPkgDbStack :: (MonadIO m, GmEnv m) => m (Maybe [GhcPkgDb]) getCustomPkgDbStack = do mCusPkgDbFile <- liftIO . (traverse readFile <=< findCustomPackageDbFile) . cradleRootDir =<< cradle return $ parseCustomPackageDb <$> mCusPkgDbFile ghc-mod-5.8.0.0/core/GhcMod/DebugLogger.hs0000644000000000000000000001262713112432356016211 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE CPP, RankNTypes #-} module GhcMod.DebugLogger where -- (c) The University of Glasgow 2005 -- -- The Glasgow Haskell Compiler License -- -- Copyright 2002, The University Court of the University of Glasgow. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are met: -- -- - Redistributions of source code must retain the above copyright notice, -- this list of conditions and the following disclaimer. -- -- - Redistributions in binary form must reproduce the above copyright notice, -- this list of conditions and the following disclaimer in the documentation -- and/or other materials provided with the distribution. -- -- - Neither name of the University nor the names of its contributors may be -- used to endorse or promote products derived from this software without -- specific prior written permission. -- -- THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF -- GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, -- INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -- FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -- UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE -- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH -- DAMAGE. import GHC import FastString import Pretty import Outputable (SDoc, PprStyle, runSDoc, initSDocContext, blankLine) import qualified Outputable import ErrUtils import GhcMod.Error import GhcMod.Gap import Prelude debugLogAction :: (String -> IO ()) -> GmLogAction debugLogAction putErr _reason dflags severity srcSpan style' msg = case severity of SevOutput -> printSDoc putErr msg style' #if __GLASGOW_HASKELL__ >= 706 SevDump -> printSDoc putErr (msg Outputable.$$ blankLine) style' #endif #if __GLASGOW_HASKELL__ >= 708 SevInteractive -> let putStrSDoc = debugLogActionHPutStrDoc dflags putErr in putStrSDoc msg style' #endif SevInfo -> printErrs putErr msg style' SevFatal -> printErrs putErr msg style' _ -> do putErr "\n" #if __GLASGOW_HASKELL__ >= 706 printErrs putErr (mkLocMessage severity srcSpan msg) style' #else printErrs putErr (mkLocMessage srcSpan msg) style' #endif -- careful (#2302): printErrs prints in UTF-8, -- whereas converting to string first and using -- hPutStr would just emit the low 8 bits of -- each unicode char. where #if __GLASGOW_HASKELL__ >= 706 printSDoc put = debugLogActionHPrintDoc dflags put printErrs put = debugLogActionHPrintDoc dflags put #endif #if __GLASGOW_HASKELL__ >= 706 debugLogActionHPrintDoc :: DynFlags -> (String -> IO ()) -> SDoc -> PprStyle -> IO () debugLogActionHPrintDoc dflags put d sty = debugLogActionHPutStrDoc dflags put (d Outputable.$$ Outputable.text "") sty -- Adds a newline debugLogActionHPutStrDoc :: DynFlags -> (String -> IO ()) -> SDoc -> PprStyle -> IO () debugLogActionHPutStrDoc dflags put d sty = gmPrintDoc_ Pretty.PageMode (pprCols dflags) put doc where -- Don't add a newline at the end, so that successive -- calls to this log-action can output all on the same line doc = runSDoc d (initSDocContext dflags sty) #else printSDoc = printErrs printErrs :: (String -> IO ()) -> SDoc -> PprStyle -> IO () printErrs put doc sty = do gmPrintDoc PageMode 100 put (runSDoc doc (initSDocContext sty)) #endif gmPrintDoc :: Mode -> Int -> (String -> IO ()) -> Doc -> IO () -- printDoc adds a newline to the end gmPrintDoc mode cols put doc = gmPrintDoc_ mode cols put (doc $$ text "") gmPrintDoc_ :: Mode -> Int -> (String -> IO ()) -> Doc -> IO () gmPrintDoc_ mode pprCols putS doc = fullRender mode pprCols 1.5 put done doc where put (Chr c) next = putS [c] >> next put (Str s) next = putS s >> next put (PStr s) next = putS (unpackFS s) >> next #if __GLASGOW_HASKELL__ >= 708 put (ZStr s) next = putS (zString s) >> next #endif put (LStr s _l) next = putS (unpackLitString s) >> next done = return () -- hPutChar hdl '\n' ghc-mod-5.8.0.0/core/GhcMod/Doc.hs0000644000000000000000000000111613112432356014517 0ustar0000000000000000module 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 ghc-mod-5.8.0.0/core/GhcMod/DynFlags.hs0000644000000000000000000000611013112432356015520 0ustar0000000000000000{-# 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 |] ghc-mod-5.8.0.0/core/GhcMod/DynFlagsTH.hs0000644000000000000000000001235113112432356015760 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE CPP, TemplateHaskell #-} module GhcMod.DynFlagsTH where import Language.Haskell.TH import Language.Haskell.TH.Syntax import Control.Applicative import Data.Maybe import Data.Generics.Aliases import Data.Generics.Schemes import DynFlags import Prelude deriveEqDynFlags :: Q [Dec] -> Q [Dec] deriveEqDynFlags qds = do #if __GLASGOW_HASKELL__ <= 710 ~(TyConI (DataD [] _ [] [ctor] _ )) #else ~(TyConI (DataD [] _ [] _ [ctor] _ )) #endif <- reify ''DynFlags let ~(RecC _ fs) = ctor a <- newName "a" b <- newName "b" e <- AppE (VarE 'and) . ListE <$> sequence (catMaybes $ map (eq a b) fs) tysig@(SigD n _) :_ <- qds return $ [tysig, FunD n [Clause [VarP a, VarP b] (NormalB e) []]] where eq :: Name -> Name -> (Name, Strict, Type) -> Maybe (Q Exp) eq a b (fun@(Name (OccName fon) _), _, ft) | not (isUneqable || isIgnored) = Just expr | otherwise = Nothing where isUneqable = everything (||) (mkQ False hasUnEqable) ft hasUnEqable (AppT (ConT (Name (OccName on) _)) _) | any (==on) ignoredConstructorNames = True hasUnEqable (ConT (Name (OccName on) _)) | any (==on) ignoredTypeNames = True | any (==on) ignoredTypeOccNames = True hasUnEqable _ = False isIgnored = fon `elem` ignoredNames ignoredConstructorNames = [ "IORef" ] ignoredNames = [ "pkgDatabase" -- 7.8 #if __GLASGOW_HASKELL__ <= 706 , "ways" -- 'Ways' is not exported :/ #endif ] ignoredTypeNames = [ "LogAction" , "PackageState" , "Hooks" , "FlushOut" , "FlushErr" , "Settings" -- I think these can't cange at runtime ] ignoredTypeOccNames = [ "OnOff" ] fa = AppE (VarE fun) (VarE a) fb = AppE (VarE fun) (VarE b) expr = case fon of "rtsOptsEnabled" -> do let eqfn = [| let fn RtsOptsNone RtsOptsNone = True fn RtsOptsSafeOnly RtsOptsSafeOnly = True fn RtsOptsAll RtsOptsAll = True fn _ _ = False in fn |] [e| $(eqfn) $(return fa) $(return fb) |] "extraPkgConfs" -> do let eqfn = [| let fn a' b' = and (zipWith eqpr (a' []) (b' [])) && length (a' []) == length (b' []) eqpr GlobalPkgConf GlobalPkgConf = True eqpr UserPkgConf UserPkgConf = True eqpr (PkgConfFile pa) (PkgConfFile pb) = pa == pb eqpr _ _ = False in fn |] [e| $(eqfn) $(return fa) $(return fb) |] #if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 800 "sigOf" -> do let eqfn = [| let fn NotSigOf NotSigOf = True fn (SigOf a') (SigOf b') = a' == b' fn (SigOfMap a') (SigOfMap b') = a' == b' fn _ _ = False in fn |] [e| $(eqfn) $(return fa) $(return fb) |] #endif #if __GLASGOW_HASKELL <= 706 "profAuto" -> do let eqfn = [| let fn NoProfAuto NoProfAuto = True fn ProfAutoAll ProfAutoAll = True fn ProfAutoTop ProfAutoTop = True fn ProfAutoExports ProfAutoExports = True fn ProfAutoCalls ProfAutoCalls = True fn _ _ = False in fn |] [e| $(eqfn) $(return fa) $(return fb) |] #endif #if __GLASGOW_HASKELL__ >= 706 "language" -> do let eqfn = [| let fn (Just Haskell98) (Just Haskell98) = True fn (Just Haskell2010) (Just Haskell2010) = True fn Nothing Nothing = True fn _ _ = False in fn |] [e| $(eqfn) $(return fa) $(return fb) |] #endif _ -> [e| $(return fa) == $(return fb) |] -- expr' = [e| trace (if $(expr) == True then "" else show ($(litE $ StringL fon), $(expr))) $(expr) |] ghc-mod-5.8.0.0/core/GhcMod/Error.hs0000644000000000000000000001303113112432356015102 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE ExistentialQuantification #-} module GhcMod.Error ( GhcModError(..) , GmError , gmeDoc , ghcExceptionDoc , liftMaybe , overrideError , modifyError , modifyError' , modifyGmError , tryFix , GHandler(..) , gcatches , module Control.Monad.Error , module Control.Exception ) where import Control.Arrow hiding ((<+>)) import Control.Exception import Control.Monad.Error hiding (MonadIO, liftIO) import qualified Data.Set as Set import Data.List import Data.Version import System.Process (showCommandForUser) import Text.Printf import Exception import Panic import Pretty import Config (cProjectVersion, cHostPlatformString) import Paths_ghc_mod (version) import GhcMod.Types import GhcMod.Pretty type GmError m = MonadError GhcModError m gmeDoc :: GhcModError -> Doc gmeDoc e = case e of GMENoMsg -> text "Unknown error" GMEString msg -> text msg GMECabalConfigure msg -> text "Configuring cabal project failed" <+>: gmeDoc msg GMEStackConfigure msg -> text "Configuring stack project failed" <+>: gmeDoc msg GMEStackBootstrap msg -> text "Bootstrapping stack project environment failed" <+>: gmeDoc msg GMECabalCompAssignment ctx -> text "Could not find a consistent component assignment for modules:" $$ (nest 4 $ foldr ($+$) empty $ map ctxDoc ctx) $$ text "" $$ (if all (Set.null . snd) ctx then noComponentSuggestions else empty) $$ text "- To find out which components ghc-mod knows about try:" $$ nest 4 (backticks $ text "ghc-mod debug") where noComponentSuggestions = text "- Are some of these modules part of a test and or benchmark?\ \ Try enabling them:" $$ nest 4 (backticks $ text "cabal configure --enable-tests [--enable-benchmarks]") backticks d = char '`' <> d <> char '`' ctxDoc = moduleDoc *** compsDoc >>> first (<> colon) >>> uncurry (flip hang 4) moduleDoc (Left fn) = text "File " <> quotes (text fn) moduleDoc (Right mdl) = text "Module " <> quotes (text $ moduleNameString mdl) compsDoc sc | Set.null sc = text "has no known components" compsDoc sc = fsep $ punctuate comma $ map gmComponentNameDoc $ Set.toList sc GMEProcess _fn cmd args emsg -> let c = showCommandForUser cmd args in case emsg of Right err -> text (printf "Launching system command `%s` failed: " c) <> gmeDoc err Left rv -> text $ printf "Launching system command `%s` failed (exited with %d)" c rv GMENoCabalFile -> text "No cabal file found." GMETooManyCabalFiles cfs -> text $ "Multiple cabal files found. Possible cabal files: \"" ++ intercalate "\", \"" cfs ++"\"." ghcExceptionDoc :: GhcException -> Doc ghcExceptionDoc e@(CmdLineError _) = text $ ": " ++ showGhcException e "" ghcExceptionDoc (UsageError str) = strDoc str ghcExceptionDoc (Panic msg) = vcat $ map text $ lines $ printf "\ \GHC panic! (the 'impossible' happened)\n\ \ ghc-mod version %s\n\ \ GHC library version %s for %s:\n\ \ %s\n\ \\n\ \Please report this as a bug: %s\n" gmVer ghcVer platform msg url where gmVer = showVersion version ghcVer = cProjectVersion platform = cHostPlatformString url = "https://github.com/kazu-yamamoto/ghc-mod/issues" :: String ghcExceptionDoc e = text $ showGhcException e "" liftMaybe :: MonadError e m => e -> m (Maybe a) -> m a liftMaybe e action = maybe (throwError e) return =<< action overrideError :: MonadError e m => e -> m a -> m a overrideError e action = modifyError (const e) action modifyError :: MonadError e m => (e -> e) -> m a -> m a modifyError f action = action `catchError` \e -> throwError $ f e infixr 0 `modifyError'` modifyError' :: MonadError e m => m a -> (e -> e) -> m a modifyError' = flip modifyError modifyGmError :: (MonadIO m, ExceptionMonad m) => (GhcModError -> GhcModError) -> m a -> m a modifyGmError f a = gcatch a $ \(ex :: GhcModError) -> liftIO $ throwIO (f ex) tryFix :: MonadError e m => m a -> (e -> m ()) -> m a tryFix action f = do action `catchError` \e -> f e >> action data GHandler m a = forall e . Exception e => GHandler (e -> m a) gcatches :: (MonadIO m, ExceptionMonad m) => m a -> [GHandler m a] -> m a gcatches io handlers = io `gcatch` gcatchesHandler handlers gcatchesHandler :: (MonadIO m, ExceptionMonad m) => [GHandler m a] -> SomeException -> m a gcatchesHandler handlers e = foldr tryHandler (liftIO $ throw e) handlers where tryHandler (GHandler handler) res = case fromException e of Just e' -> handler e' Nothing -> res ghc-mod-5.8.0.0/core/GhcMod/FileMapping.hs0000644000000000000000000000671013112432356016212 0ustar0000000000000000module 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' ghc-mod-5.8.0.0/core/GhcMod/Gap.hs0000644000000000000000000005437013112432356014533 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP, ScopedTypeVariables, RankNTypes #-} module GhcMod.Gap ( GhcMod.Gap.ClsInst , mkTarget , withStyle , GmLogAction , setLogAction , getSrcSpan , getSrcFile , withInteractiveContext , ghcCmdOptions , toStringBuffer , showSeverityCaption , setCabalPkg , setHideAllPackages , setDeferTypeErrors , setDeferTypedHoles , setWarnTypedHoles , setDumpSplices , setNoMaxRelevantBindings , isDumpSplices , filterOutChildren , infoThing , pprInfo , HasType(..) , errorMsgSpan , setErrorMsgSpan , typeForUser , nameForUser , occNameForUser , deSugar , showDocWith , renderGm , GapThing(..) , fromTyThing , fileModSummary , WarnFlags , emptyWarnFlags , GLMatch , GLMatchI , getClass , occName , listVisibleModuleNames , listVisibleModules , lookupModulePackageInAllPackages , GhcMod.Gap.isSynTyCon , parseModuleHeader , mkErrStyle' , everythingStagedWithContext , withCleanupSession ) where import Control.Applicative hiding (empty) import Control.Monad (filterM) import CoreSyn (CoreExpr) import Data.List (intersperse) import Data.Maybe (catMaybes) import Data.Time.Clock (UTCTime) import Data.Traversable hiding (mapM) import DataCon (dataConUserType) import Desugar (deSugarExpr) import DynFlags import ErrUtils import Exception import FastString import GhcMonad import HscTypes import NameSet import OccName import Outputable import PprTyThing import StringBuffer import TcType import Var (varType) import System.Directory import SysTools #if __GLASGOW_HASKELL__ >= 800 import GHCi (stopIServ) #endif import qualified Name import qualified InstEnv import qualified Pretty import qualified StringBuffer as SB #if __GLASGOW_HASKELL__ >= 710 import CoAxiom (coAxiomTyCon) #endif #if __GLASGOW_HASKELL__ >= 708 import FamInstEnv import ConLike (ConLike(..)) import PatSyn #else import TcRnTypes #endif -- GHC 7.8 doesn't define this macro, nor does GHC 7.10.0 -- It IS defined from 7.10.1 and up though. -- So we can only test for 7.10.1.0 and up with it. #if __GLASGOW_HASKELL__ < 710 #ifndef MIN_VERSION_GLASGOW_HASKELL #define MIN_VERSION_GLASGOW_HASKELL(a,b,c,d) FALSE #endif #endif #if MIN_VERSION_GLASGOW_HASKELL(8,0,1,20161117) import GHC hiding (ClsInst, withCleanupSession) import qualified GHC (withCleanupSession) #elif __GLASGOW_HASKELL__ >= 706 import GHC hiding (ClsInst) #else import GHC hiding (Instance) import Control.Arrow hiding ((<+>)) import Data.Convertible import RdrName (rdrNameOcc) #endif #if __GLASGOW_HASKELL__ < 710 import UniqFM (eltsUFM) import Module #endif #if __GLASGOW_HASKELL__ >= 704 import qualified Data.IntSet as I (IntSet, empty) #endif #if __GLASGOW_HASKELL__ < 706 import Control.DeepSeq (NFData(rnf)) import Data.ByteString.Lazy.Internal (ByteString(..)) #endif import Bag import Lexer as L import Parser import SrcLoc import Packages import Data.Generics (GenericQ, extQ, gmapQ) import GHC.SYB.Utils (Stage(..)) import GhcMod.Types (Expression(..)) import Prelude ---------------------------------------------------------------- ---------------------------------------------------------------- -- #if __GLASGOW_HASKELL__ >= 706 type ClsInst = InstEnv.ClsInst #else type ClsInst = InstEnv.Instance #endif mkTarget :: TargetId -> Bool -> Maybe (SB.StringBuffer, UTCTime) -> Target #if __GLASGOW_HASKELL__ >= 706 mkTarget = Target #else mkTarget tid allowObjCode = Target tid allowObjCode . (fmap . second) convert #endif ---------------------------------------------------------------- ---------------------------------------------------------------- withStyle :: DynFlags -> PprStyle -> SDoc -> Pretty.Doc #if __GLASGOW_HASKELL__ >= 706 withStyle = withPprStyleDoc #else withStyle _ = withPprStyleDoc #endif #if __GLASGOW_HASKELL__ >= 800 -- flip LogAction type GmLogAction = WarnReason -> DynFlags -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO () #elif __GLASGOW_HASKELL__ >= 706 type GmLogAction = forall a. a -> LogAction #else type GmLogAction = forall a. a -> DynFlags -> LogAction #endif -- DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO () setLogAction :: DynFlags -> GmLogAction -> DynFlags setLogAction df f = #if __GLASGOW_HASKELL__ >= 800 df { log_action = flip f } #elif __GLASGOW_HASKELL__ >= 706 df { log_action = f (error "setLogAction") } #else df { log_action = f (error "setLogAction") df } #endif showDocWith :: DynFlags -> Pretty.Mode -> Pretty.Doc -> String #if __GLASGOW_HASKELL__ >= 800 showDocWith dflags mode = Pretty.renderStyle mstyle where mstyle = Pretty.style { Pretty.mode = mode, Pretty.lineLength = pprCols dflags } #elif __GLASGOW_HASKELL__ >= 708 -- Pretty.showDocWith disappeard. -- https://github.com/ghc/ghc/commit/08a3536e4246e323fbcd8040e0b80001950fe9bc showDocWith dflags mode = Pretty.showDoc mode (pprCols dflags) #else showDocWith _ = Pretty.showDocWith #endif renderGm :: Pretty.Doc -> String #if __GLASGOW_HASKELL__ >= 800 renderGm = Pretty.fullRender Pretty.PageMode 80 1.2 string_txt "" #else renderGm = Pretty.fullRender Pretty.PageMode 80 1.2 string_txt "" #endif where string_txt :: Pretty.TextDetails -> String -> String string_txt (Pretty.Chr c) s = c:s string_txt (Pretty.Str s1) s2 = s1 ++ s2 string_txt (Pretty.PStr s1) s2 = unpackFS s1 ++ s2 string_txt (Pretty.LStr s1 _) s2 = unpackLitString s1 ++ s2 #if __GLASGOW_HASKELL__ >= 708 string_txt (Pretty.ZStr s1) s2 = zString s1 ++ s2 #endif ---------------------------------------------------------------- ---------------------------------------------------------------- getSrcSpan :: SrcSpan -> Maybe (Int,Int,Int,Int) #if __GLASGOW_HASKELL__ >= 702 getSrcSpan (RealSrcSpan spn) #else getSrcSpan spn | isGoodSrcSpan spn #endif = Just (srcSpanStartLine spn , srcSpanStartCol spn , srcSpanEndLine spn , srcSpanEndCol spn) getSrcSpan _ = Nothing getSrcFile :: SrcSpan -> Maybe String #if __GLASGOW_HASKELL__ >= 702 getSrcFile (RealSrcSpan spn) = Just . unpackFS . srcSpanFile $ spn #else getSrcFile spn | isGoodSrcSpan spn = Just . unpackFS . srcSpanFile $ spn #endif getSrcFile _ = Nothing ---------------------------------------------------------------- toStringBuffer :: GhcMonad m => [String] -> m StringBuffer #if __GLASGOW_HASKELL__ >= 702 toStringBuffer = return . stringToStringBuffer . unlines #else toStringBuffer = liftIO . stringToStringBuffer . unlines #endif ---------------------------------------------------------------- ghcCmdOptions :: [String] #if __GLASGOW_HASKELL__ >= 710 -- this also includes -X options and all sorts of other things so the ghcCmdOptions = flagsForCompletion False #else ghcCmdOptions = [ "-f" ++ prefix ++ option | option <- opts , prefix <- ["","no-"] ] # if __GLASGOW_HASKELL__ >= 704 where opts = [option | (option,_,_) <- fFlags] ++ [option | (option,_,_) <- fWarningFlags] ++ [option | (option,_,_) <- fLangFlags] # else where opts = [option | (option,_,_,_) <- fFlags] ++ [option | (option,_,_,_) <- fWarningFlags] ++ [option | (option,_,_,_) <- fLangFlags] # endif #endif ---------------------------------------------------------------- ---------------------------------------------------------------- fileModSummary :: GhcMonad m => FilePath -> m ModSummary fileModSummary file' = do mss <- getModuleGraph file <- liftIO $ canonicalizePath file' [ms] <- liftIO $ flip filterM mss $ \m -> (Just file==) <$> canonicalizePath `traverse` ml_hs_file (ms_location m) return ms withInteractiveContext :: GhcMonad m => m a -> m a withInteractiveContext action = gbracket setup teardown body where setup = getContext teardown = setCtx body _ = do topImports >>= setCtx action topImports = do ms <- filterM moduleIsInterpreted =<< map ms_mod <$> getModuleGraph let iis = map (IIModule . modName) ms #if __GLASGOW_HASKELL__ >= 704 return iis #else return (iis,[]) #endif #if __GLASGOW_HASKELL__ >= 706 modName = moduleName setCtx = setContext #elif __GLASGOW_HASKELL__ >= 704 modName = id setCtx = setContext #else modName = ms_mod setCtx = uncurry setContext #endif showSeverityCaption :: Severity -> String #if __GLASGOW_HASKELL__ >= 706 showSeverityCaption SevWarning = "Warning: " showSeverityCaption _ = "" #else showSeverityCaption = const "" #endif ---------------------------------------------------------------- ---------------------------------------------------------------- setCabalPkg :: DynFlags -> DynFlags #if __GLASGOW_HASKELL__ >= 708 setCabalPkg dflag = gopt_set dflag Opt_BuildingCabalPackage #else setCabalPkg dflag = dopt_set dflag Opt_BuildingCabalPackage #endif ---------------------------------------------------------------- setHideAllPackages :: DynFlags -> DynFlags #if __GLASGOW_HASKELL__ >= 708 setHideAllPackages df = gopt_set df Opt_HideAllPackages #else setHideAllPackages df = dopt_set df Opt_HideAllPackages #endif ---------------------------------------------------------------- setDumpSplices :: DynFlags -> DynFlags setDumpSplices dflag = dopt_set dflag Opt_D_dump_splices isDumpSplices :: DynFlags -> Bool isDumpSplices dflag = dopt Opt_D_dump_splices dflag ---------------------------------------------------------------- setDeferTypeErrors :: DynFlags -> DynFlags #if __GLASGOW_HASKELL__ >= 708 setDeferTypeErrors dflag = gopt_set dflag Opt_DeferTypeErrors #elif __GLASGOW_HASKELL__ >= 706 setDeferTypeErrors dflag = dopt_set dflag Opt_DeferTypeErrors #else setDeferTypeErrors = id #endif setDeferTypedHoles :: DynFlags -> DynFlags #if __GLASGOW_HASKELL__ >= 710 setDeferTypedHoles dflag = gopt_set dflag Opt_DeferTypedHoles #else setDeferTypedHoles = id #endif setWarnTypedHoles :: DynFlags -> DynFlags #if __GLASGOW_HASKELL__ >= 708 setWarnTypedHoles dflag = wopt_set dflag Opt_WarnTypedHoles #else setWarnTypedHoles = id #endif ---------------------------------------------------------------- -- | Set 'DynFlags' equivalent to "-fno-max-relevant-bindings". setNoMaxRelevantBindings :: DynFlags -> DynFlags #if __GLASGOW_HASKELL__ >= 708 setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing } #else setNoMaxRelevantBindings = id #endif ---------------------------------------------------------------- ---------------------------------------------------------------- class HasType a where getType :: GhcMonad m => TypecheckedModule -> a -> m (Maybe (SrcSpan, Type)) instance HasType (LHsBind Id) where #if __GLASGOW_HASKELL__ >= 708 getType _ (L spn FunBind{fun_matches = m}) = return $ Just (spn, typ) where in_tys = mg_arg_tys m out_typ = mg_res_ty m typ = mkFunTys in_tys out_typ #else getType _ (L spn FunBind{fun_matches = MatchGroup _ typ}) = return $ Just (spn, typ) #endif getType _ _ = return Nothing ---------------------------------------------------------------- ---------------------------------------------------------------- -- from ghc/InteractiveUI.hs filterOutChildren :: (a -> TyThing) -> [a] -> [a] filterOutChildren get_thing xs = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)] where implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] infoThing :: GhcMonad m => (FilePath -> FilePath) -> Expression -> m SDoc infoThing m (Expression str) = do names <- parseName str #if __GLASGOW_HASKELL__ >= 708 mb_stuffs <- mapM (getInfo False) names let filtered = filterOutChildren (\(t,_f,_i,_fam) -> t) (catMaybes mb_stuffs) #else mb_stuffs <- mapM getInfo names let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs) #endif return $ vcat (intersperse (text "") $ map (pprInfo m False) filtered) #if __GLASGOW_HASKELL__ >= 708 pprInfo :: (FilePath -> FilePath) -> Bool -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc pprInfo m _ (thing, fixity, insts, famInsts) = pprTyThingInContextLoc' thing $$ show_fixity fixity $$ vcat (map pprInstance' insts) $$ vcat (map pprFamInst' famInsts) #else pprInfo :: (FilePath -> FilePath) -> PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst]) -> SDoc pprInfo m pefas (thing, fixity, insts) = pprTyThingInContextLoc' pefas thing $$ show_fixity fixity $$ vcat (map pprInstance' insts) #endif where show_fixity fx | fx == defaultFixity = Outputable.empty | otherwise = ppr fx <+> ppr (getName thing) #if __GLASGOW_HASKELL__ >= 708 pprTyThingInContextLoc' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext thing') #if __GLASGOW_HASKELL__ >= 710 pprFamInst' (FamInst { fi_flavor = DataFamilyInst rep_tc }) = pprTyThingInContextLoc (ATyCon rep_tc) pprFamInst' (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom , fi_tys = lhs_tys, fi_rhs = rhs }) = showWithLoc (pprDefinedAt' (getName axiom)) $ hang (ptext (sLit "type instance") <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys) 2 (equals <+> ppr rhs) #else pprFamInst' ispec = showWithLoc (pprDefinedAt' (getName ispec)) (pprFamInstHdr ispec) #endif #else pprTyThingInContextLoc' pefas' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext pefas' thing') #endif showWithLoc loc doc = hang doc 2 (char '\t' <> comment <+> loc) -- The tab tries to make them line up a bit where comment = ptext (sLit "--") pprInstance' ispec = hang (pprInstanceHdr ispec) 2 (ptext (sLit "--") <+> pprDefinedAt' (getName ispec)) pprDefinedAt' thing' = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing') pprNameDefnLoc' name = case Name.nameSrcLoc name of RealSrcLoc s -> ptext (sLit "at") <+> ppr (subst s) UnhelpfulLoc s | Name.isInternalName name || Name.isSystemName name -> ptext (sLit "at") <+> ftext s | otherwise -> ptext (sLit "in") <+> quotes (ppr (nameModule name)) where subst s = mkRealSrcLoc (realFP s) (srcLocLine s) (srcLocCol s) realFP = mkFastString . m . unpackFS . srcLocFile ---------------------------------------------------------------- ---------------------------------------------------------------- errorMsgSpan :: ErrMsg -> SrcSpan #if __GLASGOW_HASKELL__ >= 708 errorMsgSpan = errMsgSpan #else errorMsgSpan = head . errMsgSpans #endif setErrorMsgSpan :: ErrMsg -> SrcSpan -> ErrMsg #if __GLASGOW_HASKELL__ >= 708 setErrorMsgSpan err s = err { errMsgSpan = s } #else setErrorMsgSpan err s = err { errMsgSpans = [s] } #endif typeForUser :: Type -> SDoc #if __GLASGOW_HASKELL__ >= 708 typeForUser = pprTypeForUser #else typeForUser = pprTypeForUser False #endif nameForUser :: Name -> SDoc nameForUser = pprOccName . getOccName occNameForUser :: OccName -> SDoc occNameForUser = pprOccName deSugar :: TypecheckedModule -> LHsExpr Id -> HscEnv -> IO (Maybe CoreExpr) #if __GLASGOW_HASKELL__ >= 708 deSugar _ e hs_env = snd <$> deSugarExpr hs_env e #else deSugar tcm e hs_env = snd <$> deSugarExpr hs_env modu rn_env ty_env e where modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm tcgEnv = fst $ tm_internals_ tcm rn_env = tcg_rdr_env tcgEnv ty_env = tcg_type_env tcgEnv #endif ---------------------------------------------------------------- ---------------------------------------------------------------- data GapThing = GtA Type | GtT TyCon | GtN #if __GLASGOW_HASKELL__ >= 800 | GtPatSyn PatSyn #endif fromTyThing :: TyThing -> GapThing fromTyThing (AnId i) = GtA $ varType i #if __GLASGOW_HASKELL__ >= 708 fromTyThing (AConLike (RealDataCon d)) = GtA $ dataConUserType d #if __GLASGOW_HASKELL__ >= 800 fromTyThing (AConLike (PatSynCon p)) = GtPatSyn p #else fromTyThing (AConLike (PatSynCon p)) = GtA $ patSynType p #endif #else fromTyThing (ADataCon d) = GtA $ dataConUserType d #endif fromTyThing (ATyCon t) = GtT t fromTyThing _ = GtN ---------------------------------------------------------------- ---------------------------------------------------------------- #if __GLASGOW_HASKELL__ >= 704 type WarnFlags = I.IntSet emptyWarnFlags :: WarnFlags emptyWarnFlags = I.empty #else type WarnFlags = [WarningFlag] emptyWarnFlags :: WarnFlags emptyWarnFlags = [] #endif ---------------------------------------------------------------- ---------------------------------------------------------------- #if __GLASGOW_HASKELL__ >= 708 type GLMatch = LMatch RdrName (LHsExpr RdrName) type GLMatchI = LMatch Id (LHsExpr Id) #else type GLMatch = LMatch RdrName type GLMatchI = LMatch Id #endif getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan) #if __GLASGOW_HASKELL__ >= 800 -- Instance declarations of sort 'instance F (G a)' getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = HsIB _ (L _ (HsForAllTy _ (L _ (HsAppTy (L _ (HsTyVar (L _ className))) _))))}))] = Just (className, loc) -- Instance declarations of sort 'instance F G' (no variables) getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = HsIB _ (L _ (HsAppTy (L _ (HsTyVar (L _ className))) _))}))] = Just (className, loc) #elif __GLASGOW_HASKELL__ >= 710 -- Instance declarations of sort 'instance F (G a)' getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsForAllTy _ _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _))))}))] = Just (className, loc) -- Instance declarations of sort 'instance F G' (no variables) getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsAppTy (L _ (HsTyVar className)) _))}))] = Just (className, loc) #elif __GLASGOW_HASKELL__ >= 708 -- Instance declarations of sort 'instance F (G a)' getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _))))}))] = Just (className, loc) -- Instance declarations of sort 'instance F G' (no variables) getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsAppTy (L _ (HsTyVar className)) _))}))] = Just (className, loc) #elif __GLASGOW_HASKELL__ >= 706 getClass [L loc (ClsInstD (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _)))) _ _ _)] = Just (className, loc) getClass[L loc (ClsInstD (L _ (HsAppTy (L _ (HsTyVar className)) _)) _ _ _)] = Just (className, loc) #else getClass [L loc (InstDecl (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _)))) _ _ _)] = Just (className, loc) getClass [L loc (InstDecl (L _ (HsAppTy (L _ (HsTyVar className)) _)) _ _ _)] = Just (className, loc) #endif getClass _ = Nothing #if __GLASGOW_HASKELL__ < 706 occName :: RdrName -> OccName occName = rdrNameOcc #endif ---------------------------------------------------------------- #if __GLASGOW_HASKELL__ < 710 -- Copied from ghc/InteractiveUI.hs allExposedPackageConfigs :: DynFlags -> [PackageConfig] allExposedPackageConfigs df = filter exposed $ eltsUFM $ pkgIdMap $ pkgState df allExposedModules :: DynFlags -> [ModuleName] allExposedModules df = concat $ map exposedModules $ allExposedPackageConfigs df listVisibleModuleNames :: DynFlags -> [ModuleName] listVisibleModuleNames = allExposedModules #endif lookupModulePackageInAllPackages :: DynFlags -> ModuleName -> [String] lookupModulePackageInAllPackages df mn = #if __GLASGOW_HASKELL__ >= 710 unpackSPId . sourcePackageId . snd <$> lookupModuleInAllPackages df mn where unpackSPId (SourcePackageId fs) = unpackFS fs #else unpackPId . sourcePackageId . fst <$> lookupModuleInAllPackages df mn where unpackPId pid = packageIdString $ mkPackageId pid -- n ++ "-" ++ showVersion v #endif listVisibleModules :: DynFlags -> [GHC.Module] listVisibleModules df = let #if __GLASGOW_HASKELL__ >= 710 modNames = listVisibleModuleNames df mods = [ m | mn <- modNames, (m, _) <- lookupModuleInAllPackages df mn ] #else pkgCfgs = allExposedPackageConfigs df mods = [ mkModule pid modname | p <- pkgCfgs , let pid = packageConfigId p , modname <- exposedModules p ] #endif in mods isSynTyCon :: TyCon -> Bool #if __GLASGOW_HASKELL__ >= 710 isSynTyCon = GHC.isTypeSynonymTyCon #else isSynTyCon = GHC.isSynTyCon #endif parseModuleHeader :: String -- ^ Haskell module source text (full Unicode is supported) -> DynFlags -> FilePath -- ^ the filename (for source locations) -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName)) parseModuleHeader str dflags filename = let loc = mkRealSrcLoc (mkFastString filename) 1 1 buf = stringToStringBuffer str in case L.unP Parser.parseHeader (mkPState dflags buf loc) of PFailed sp err -> #if __GLASGOW_HASKELL__ >= 706 Left (unitBag (mkPlainErrMsg dflags sp err)) #else Left (unitBag (mkPlainErrMsg sp err)) #endif POk pst rdr_module -> let (warns,_) = getMessages pst in Right (warns, rdr_module) mkErrStyle' :: DynFlags -> PrintUnqualified -> PprStyle #if __GLASGOW_HASKELL__ >= 706 mkErrStyle' = Outputable.mkErrStyle #else mkErrStyle' _ = Outputable.mkErrStyle #endif #if __GLASGOW_HASKELL__ < 706 instance NFData ByteString where rnf Empty = () rnf (Chunk _ b) = rnf b #endif -- | Like 'everything', but avoid known potholes, based on the 'Stage' that -- generated the Ast. everythingStagedWithContext :: Stage -> s -> (r -> r -> r) -> r -> GenericQ (s -> (r, s)) -> GenericQ r everythingStagedWithContext stage s0 f z q x | (const False #if __GLASGOW_HASKELL__ <= 708 `extQ` postTcType #endif `extQ` fixity `extQ` nameSet) x = z | otherwise = foldl f r (gmapQ (everythingStagedWithContext stage s' f z q) x) where nameSet = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool #if __GLASGOW_HASKELL__ <= 708 postTcType = const (stage Bool #endif fixity = const (stage Bool (r, s') = q x s0 withCleanupSession :: GhcMonad m => m a -> m a #if __GLASGOW_HASKELL__ >= 800 #if MIN_VERSION_GLASGOW_HASKELL(8,0,1,20161117) withCleanupSession = GHC.withCleanupSession #else withCleanupSession ghc = ghc `gfinally` cleanup where cleanup = do hsc_env <- getSession let dflags = hsc_dflags hsc_env liftIO $ do cleanTempFiles dflags cleanTempDirs dflags stopIServ hsc_env #endif #else withCleanupSession action = do df <- getSessionDynFlags GHC.defaultCleanupHandler df action #endif ghc-mod-5.8.0.0/core/GhcMod/GhcPkg.hs0000644000000000000000000000732513112432356015165 0ustar0000000000000000{-# 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 ghc-mod-5.8.0.0/core/GhcMod/HomeModuleGraph.hs0000644000000000000000000002204713112432356017040 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE ScopedTypeVariables, RecordWildCards #-} module GhcMod.HomeModuleGraph ( GmModuleGraph(..) , ModulePath(..) , mkFileMap , mkModuleMap , mkMainModulePath , findModulePath , findModulePathSet , fileModuleName , canonicalizeModulePath , homeModuleGraph , updateHomeModuleGraph , canonicalizeModuleGraph , reachable , moduleGraphToDot ) where import DriverPipeline import DynFlags import ErrUtils import Exception import Finder import GHC import HscTypes import Pretty import Control.Arrow ((&&&)) import Control.Applicative import Control.Monad import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Control.Monad.State.Strict (execStateT) import Control.Monad.State.Class import Data.Maybe import Data.Monoid as Monoid import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import System.FilePath import System.Directory import System.IO import Prelude import GhcMod.Logging import GhcMod.Logger import GhcMod.Monad.Types import GhcMod.Types import GhcMod.Utils (withMappedFile) import GhcMod.Gap (parseModuleHeader) -- | Turn module graph into a graphviz dot file -- -- @dot -Tpng -o modules.png modules.dot@ moduleGraphToDot :: GmModuleGraph -> String moduleGraphToDot GmModuleGraph { gmgGraph } = "digraph {\n" ++ concatMap edges (Map.toList graph) ++ "}\n" where graph = Map.map (Set.mapMonotonic mpPath) $ Map.mapKeysMonotonic mpPath gmgGraph edges :: (FilePath, (Set FilePath)) -> String edges (f, sf) = concatMap (\f' -> " \""++ f ++"\" -> \""++ f' ++"\"\n") (Set.toList sf) data S = S { sErrors :: [(ModulePath, ErrorMessages)], sWarnings :: [(ModulePath, WarningMessages)], sGraph :: GmModuleGraph } defaultS :: S defaultS = S [] [] mempty putErr :: MonadState S m => (ModulePath, ErrorMessages) -> m () putErr e = do s <- get put s { sErrors = e:sErrors s} putWarn :: MonadState S m => (ModulePath, ErrorMessages) -> m () putWarn w = do s <- get put s { sWarnings = w:sWarnings s} gmgLookupMP :: MonadState S m => ModulePath -> m (Maybe (Set ModulePath)) gmgLookupMP k = (Map.lookup k . gmgGraph . sGraph) `liftM` get graphUnion :: MonadState S m => GmModuleGraph -> m () graphUnion gmg = do s <- get put s { sGraph = sGraph s `mappend` gmg } reachable :: Set ModulePath -> GmModuleGraph -> Set ModulePath reachable smp0 GmModuleGraph {..} = go smp0 where go smp = let δsmp = Set.unions $ collapseMaybeSet . flip Map.lookup gmgGraph <$> Set.toList smp smp' = smp `Set.union` δsmp in if smp == smp' then smp' else go smp' pruneUnreachable :: Set ModulePath -> GmModuleGraph -> GmModuleGraph pruneUnreachable smp0 gmg@GmModuleGraph {..} = let r = reachable smp0 gmg in GmModuleGraph { gmgGraph = Map.filterWithKey (\k _ -> k `Set.member` r) gmgGraph } collapseMaybeSet :: Maybe (Set a) -> Set a collapseMaybeSet = maybe Set.empty id homeModuleGraph :: (IOish m, Gm m) => HscEnv -> Set ModulePath -> m GmModuleGraph homeModuleGraph env smp = updateHomeModuleGraph env mempty smp smp mkMainModulePath :: FilePath -> ModulePath mkMainModulePath = ModulePath (mkModuleName "Main") findModulePath :: HscEnv -> ModuleName -> IO (Maybe ModulePath) findModulePath env mn = do fmap (ModulePath mn) <$> find env mn findModulePathSet :: HscEnv -> [ModuleName] -> IO (Set ModulePath) findModulePathSet env mns = do Set.fromList . catMaybes <$> findModulePath env `mapM` mns find :: MonadIO m => HscEnv -> ModuleName -> m (Maybe FilePath) find env mn = liftIO $ do res <- findHomeModule env mn case res of -- TODO: handle SOURCE imports (hs-boot stuff): addBootSuffixLocn loc Found loc@ModLocation { ml_hs_file = Just _ } _mod -> return $ normalise <$> ml_hs_file loc _ -> return Nothing canonicalizeModulePath :: ModulePath -> IO ModulePath canonicalizeModulePath (ModulePath mn fp) = ModulePath mn <$> canonicalizePath fp canonicalizeModuleGraph :: MonadIO m => GmModuleGraph -> m GmModuleGraph canonicalizeModuleGraph GmModuleGraph {..} = liftIO $ do GmModuleGraph . Map.fromList <$> mapM fmg (Map.toList gmgGraph) where fmg (mp, smp) = liftM2 (,) (canonicalizeModulePath mp) (Set.fromList <$> mapM canonicalizeModulePath (Set.toList smp)) updateHomeModuleGraph :: (IOish m, Gm m) => HscEnv -> GmModuleGraph -> Set ModulePath -- ^ Initial set of modules -> Set ModulePath -- ^ Updated set of modules -> m GmModuleGraph updateHomeModuleGraph env GmModuleGraph {..} smp sump = do -- TODO: It would be good if we could retain information about modules that -- stop to compile after we've already successfully parsed them at some -- point. Figure out a way to delete the modules about to be updated only -- after we're sure they won't fail to parse .. or something. Should probably -- push this whole prune logic deep into updateHomeModuleGraph' (pruneUnreachable smp . sGraph) `liftM` runS (updateHomeModuleGraph' env sump) where runS = flip execStateT defaultS { sGraph = graph' } graph' = GmModuleGraph { gmgGraph = Set.foldr Map.delete gmgGraph sump } mkFileMap :: Set ModulePath -> Map FilePath ModulePath mkFileMap smp = Map.fromList $ map (mpPath &&& id) $ Set.toList smp mkModuleMap :: Set ModulePath -> Map ModuleName ModulePath mkModuleMap smp = Map.fromList $ map (mpModule &&& id) $ Set.toList smp updateHomeModuleGraph' :: forall m. (MonadState S m, IOish m, Gm m) => HscEnv -> Set ModulePath -- ^ Initial set of modules -> m () updateHomeModuleGraph' env smp0 = do go `mapM_` Set.toList smp0 where go :: ModulePath -> m () go mp = do msmp <- gmgLookupMP mp case msmp of Just _ -> return () Nothing -> do smp <- collapseMaybeSet `liftM` step mp graphUnion GmModuleGraph { gmgGraph = Map.singleton mp smp } mapM_ go (Set.toList smp) step :: ModulePath -> m (Maybe (Set ModulePath)) step mp = runMaybeT $ do (dflags, ppsrc_fn) <- MaybeT preprocess' src <- liftIO $ readFile ppsrc_fn imports mp src dflags where preprocess' :: m (Maybe (DynFlags, FilePath)) preprocess' = do let fn = mpPath mp ep <- preprocessFile env fn case ep of Right (_, x) -> return $ Just x Left errs -> do -- TODO: Remember these and present them as proper errors if this is -- the file the user is looking at. gmLog GmWarning ("preprocess " ++ show fn) $ Pretty.empty $+$ (vcat $ map text errs) return Nothing imports :: ModulePath -> String -> DynFlags -> MaybeT m (Set ModulePath) imports mp@ModulePath {..} src dflags = case parseModuleHeader src dflags mpPath of Left err -> do putErr (mp, err) mzero Right (ws, lmdl) -> do putWarn (mp, ws) let HsModule {..} = unLoc lmdl mns = map (unLoc . ideclName) $ filter (isNothing . ideclPkgQual) $ map unLoc hsmodImports -- TODO: handle package qualifier "this" liftIO $ Set.fromList . catMaybes <$> mapM (findModulePath env) mns preprocessFile :: (IOish m, GmEnv m, GmState m) => HscEnv -> FilePath -> m (Either [String] ([String], (DynFlags, FilePath))) preprocessFile env file = withLogger' env $ \setDf -> do withMappedFile file $ \fn -> do let env' = env { hsc_dflags = setDf (hsc_dflags env) } liftIO $ preprocess env' (fn, Nothing) fileModuleName :: (IOish m, GmEnv m, GmState m) => HscEnv -> FilePath -> m (Either [String] (Maybe ModuleName)) fileModuleName env fn = do let handler = liftIO . handle (\(_ :: SomeException) -> return $ Right Nothing) ep <- preprocessFile env fn case ep of Left errs -> do return $ Left errs Right (_warns, (dflags, procdFile)) -> leftM (errBagToStrList env) =<< handler (do src <- readFile procdFile case parseModuleHeader src dflags procdFile of Left errs -> return $ Left errs Right (_, lmdl) -> do let HsModule {..} = unLoc lmdl return $ Right $ unLoc <$> hsmodName) where leftM f = either (return . Left <=< f) (return . Right) ghc-mod-5.8.0.0/core/GhcMod/LightGhc.hs0000644000000000000000000000356013112432356015510 0ustar0000000000000000module 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 ghc-mod-5.8.0.0/core/GhcMod/Logger.hs0000644000000000000000000001331313112432356015233 0ustar0000000000000000{-# 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"] ghc-mod-5.8.0.0/core/GhcMod/Logging.hs0000644000000000000000000000662613112432356015413 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE GeneralizedNewtypeDeriving #-} module GhcMod.Logging ( module GhcMod.Logging , module GhcMod.Pretty , GmLogLevel(..) , module Data.Monoid , module Pretty ) where import Control.Applicative hiding (empty) import Control.Monad import Control.Monad.Trans.Class import Data.List import Data.Char import Data.Monoid import Data.Maybe import System.IO import System.FilePath import Prelude import Pretty hiding (style, (<>)) import GhcMod.Monad.Types import GhcMod.Types import GhcMod.Pretty import GhcMod.Output gmSetLogLevel :: GmLog m => GmLogLevel -> m () gmSetLogLevel level = gmlJournal $ GhcModLog (Just level) (Last Nothing) [] gmGetLogLevel :: forall m. GmLog m => m GmLogLevel gmGetLogLevel = do GhcModLog { gmLogLevel = Just level } <- gmlHistory return level gmSetDumpLevel :: GmLog m => Bool -> m () gmSetDumpLevel level = gmlJournal $ GhcModLog Nothing (Last (Just level)) [] increaseLogLevel :: GmLogLevel -> GmLogLevel increaseLogLevel l | l == maxBound = l increaseLogLevel l = succ l decreaseLogLevel :: GmLogLevel -> GmLogLevel decreaseLogLevel l | l == minBound = l decreaseLogLevel l = pred l -- | -- >>> Just GmDebug <= Nothing -- False -- >>> Just GmException <= Just GmDebug -- True -- >>> Just GmDebug <= Just GmException -- False gmLog :: (MonadIO m, GmLog m, GmOut m) => GmLogLevel -> String -> Doc -> m () gmLog level loc' doc = do GhcModLog { gmLogLevel = Just level' } <- gmlHistory let loc | loc' == "" = empty | otherwise = text loc' <+>: empty msgDoc = sep [loc, doc] msg = dropWhileEnd isSpace $ renderGm $ gmLogLevelDoc level <+>: msgDoc when (level <= level') $ gmErrStrLn msg gmLogQuiet level loc' doc gmLogQuiet :: GmLog m => GmLogLevel -> String -> Doc -> m () gmLogQuiet level loc doc = gmlJournal (GhcModLog Nothing (Last Nothing) [(level, loc, doc)]) gmAppendLogQuiet :: GmLog m => GhcModLog -> m () gmAppendLogQuiet GhcModLog { gmLogMessages } = forM_ gmLogMessages $ \(level, loc, doc) -> gmLogQuiet level loc doc gmVomit :: (MonadIO m, GmLog m, GmOut m, GmEnv m) => String -> Doc -> String -> m () gmVomit filename doc content = do gmLog GmVomit "" $ doc <+>: text content GhcModLog { gmLogVomitDump = Last mdump } <- gmlHistory dir <- cradleTempDir `liftM` cradle when (fromMaybe False mdump) $ liftIO $ writeFile (dir filename) content newtype LogDiscardT m a = LogDiscardT { runLogDiscard :: m a } deriving (Functor, Applicative, Monad) instance MonadTrans LogDiscardT where lift = LogDiscardT instance Monad m => GmLog (LogDiscardT m) where gmlJournal = const $ return () gmlHistory = return mempty gmlClear = return () ghc-mod-5.8.0.0/core/GhcMod/Monad.hs0000644000000000000000000001144513112432356015056 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE CPP #-} module GhcMod.Monad ( runGmOutT , runGmOutT' , runGhcModT , runGhcModT' , hoistGhcModT , runGmlT , runGmlT' , runGmlTWith , runGmPkgGhc , withGhcModEnv , withGhcModEnv' , module GhcMod.Monad.Types ) where import GhcMod.Types import GhcMod.Monad.Types import GhcMod.Error import GhcMod.Logging import GhcMod.Cradle import GhcMod.Target import GhcMod.Output import Control.Arrow (first) import Control.Applicative import Control.Concurrent import Control.Monad.Reader (runReaderT) import Control.Monad.State.Strict (runStateT) import Control.Monad.Trans.Journal (runJournalT) import Exception import System.Directory import System.IO.Unsafe import Prelude withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a withGhcModEnv dir opts f = withGhcModEnv' withCradle dir opts f where withCradle dir' = gbracket (runJournalT $ do gmSetLogLevel $ ooptLogLevel $ optOutput opts findCradle' (optPrograms opts) dir') (liftIO . cleanupCradle . fst) cwdLock :: MVar ThreadId cwdLock = unsafePerformIO $ newEmptyMVar {-# NOINLINE cwdLock #-} withGhcModEnv' :: (IOish m, GmOut m) => (FilePath -> ((Cradle, GhcModLog) -> m a) -> m a) -> FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a withGhcModEnv' withCradle dir opts f = withCradle dir $ \(crdl,lg) -> withCradleRootDir crdl $ f (GhcModEnv opts crdl, lg) where swapCurrentDirectory ndir = do odir <- canonicalizePath =<< getCurrentDirectory setCurrentDirectory ndir return odir withCradleRootDir (cradleRootDir -> projdir) a = do success <- liftIO $ tryPutMVar cwdLock =<< myThreadId if not success then error "withGhcModEnv': using ghc-mod from multiple threads is not supported!" else gbracket setup teardown (const a) where setup = liftIO $ swapCurrentDirectory projdir teardown odir = liftIO $ do setCurrentDirectory odir void $ takeMVar cwdLock runGmOutT :: IOish m => Options -> GmOutT m a -> m a runGmOutT opts ma = do gmo@GhcModOut{..} <- GhcModOut (optOutput opts) <$> liftIO newChan let action = runGmOutT' gmo ma case ooptLinePrefix $ optOutput opts of Nothing -> action Just pfxs -> gbracket_ (liftIO $ forkIO $ stdoutGateway pfxs gmoChan) (const $ liftIO $ flushStdoutGateway gmoChan) action runGmOutT' :: GhcModOut -> GmOutT m a -> m a runGmOutT' gmo ma = flip runReaderT gmo $ unGmOutT ma -- | Run a @GhcModT m@ computation. runGhcModT :: IOish m => Options -> GhcModT m a -> m (Either GhcModError a, GhcModLog) runGhcModT opt action = liftIO (getCurrentDirectory >>= canonicalizePath) >>= \dir' -> do runGmOutT opt $ withGhcModEnv dir' opt $ \(env,lg) -> first (fst <$>) <$> runGhcModT' env defaultGhcModState (do gmSetLogLevel (ooptLogLevel $ optOutput opt) gmAppendLogQuiet lg action) -- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT -- computation. Note that if the computation that returned @result@ modified the -- state part of GhcModT this cannot be restored. hoistGhcModT :: IOish m => (Either GhcModError a, GhcModLog) -> GhcModT m a hoistGhcModT (r,l) = do gmlJournal l >> case r of Left e -> throwError e Right a -> return a -- | Run a computation inside @GhcModT@ providing the RWST environment and -- initial state. This is a low level function, use it only if you know what to -- do with 'GhcModEnv' and 'GhcModState'. -- -- You should probably look at 'runGhcModT' instead. runGhcModT' :: IOish m => GhcModEnv -> GhcModState -> GhcModT m a -> GmOutT m (Either GhcModError (a, GhcModState), GhcModLog) runGhcModT' r s a = do flip runReaderT r $ runJournalT $ runErrorT $ runStateT (unGmT a) s gbracket_ :: ExceptionMonad m => m a -> (a -> m b) -> m c -> m c gbracket_ ma mb mc = gbracket ma mb (const mc) ghc-mod-5.8.0.0/core/GhcMod/Output.hs0000644000000000000000000001602313112432356015315 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -- Derived from process:System.Process -- Copyright (c) The University of Glasgow 2004-2008 {-# LANGUAGE FlexibleInstances #-} module GhcMod.Output ( gmPutStr , gmErrStr , gmPutStrLn , gmErrStrLn , gmPutStrIO , gmErrStrIO , gmReadProcess , gmReadProcess' , stdoutGateway , flushStdoutGateway ) where import Data.List import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BS import qualified Data.Label as L import qualified Data.Label.Base as LB import System.IO import System.Exit import System.Process import Control.Monad import Control.Monad.State.Strict import Control.DeepSeq import Control.Exception import Control.Concurrent (forkIO, killThread) import Control.Concurrent.MVar import Control.Concurrent.Chan import Pipes import Pipes.Lift import Prelude import GhcMod.Types hiding (LineSeparator, MonadIO(..)) import GhcMod.Monad.Types hiding (MonadIO(..)) import GhcMod.Gap () class ProcessOutput a where hGetContents' :: Handle -> IO a instance ProcessOutput String where hGetContents' = hGetContents instance ProcessOutput ByteString where hGetContents' = BS.hGetContents outputFns :: (GmOut m, MonadIO m') => m (String -> m' (), String -> m' ()) outputFns = outputFns' `liftM` gmoAsk outputFns' :: MonadIO m => GhcModOut -> (String -> m (), String -> m ()) outputFns' (GhcModOut oopts c) = let OutputOpts {..} = oopts in case ooptLinePrefix of Nothing -> stdioOutputFns Just _ -> chanOutputFns c stdioOutputFns :: MonadIO m => (String -> m (), String -> m ()) stdioOutputFns = ( liftIO . putStr , liftIO . hPutStr stderr ) chanOutputFns :: MonadIO m => Chan (Either (MVar ()) (GmStream, String)) -> (String -> m (), String -> m ()) chanOutputFns c = (write GmOutStream, write GmErrStream) where write stream s = liftIO $ writeChan c $ Right $ (stream,s) gmPutStr, gmPutStrLn, gmErrStr, gmErrStrLn :: (MonadIO m, GmOut m) => String -> m () gmPutStr str = do putOut <- gmPutStrIO putOut str gmErrStr str = do putErr <- gmErrStrIO putErr str gmPutStrLn = gmPutStr . (++"\n") gmErrStrLn = gmErrStr . (++"\n") gmPutStrIO, gmErrStrIO :: (GmOut m, MonadIO mi) => m (String -> mi ()) gmPutStrIO = fst `liftM` outputFns gmErrStrIO = snd `liftM` outputFns gmReadProcess :: GmOut m => m (FilePath -> [String] -> String -> IO String) gmReadProcess = do GhcModOut {..} <- gmoAsk case ooptLinePrefix gmoOptions of Just _ -> readProcessStderrChan Nothing -> return $ readProcess gmReadProcess' :: GmOut m => m (FilePath -> [String] -> String -> IO ByteString) gmReadProcess' = readProcessStderrChan flushStdoutGateway :: Chan (Either (MVar ()) (GmStream, String)) -> IO () flushStdoutGateway c = do mv <- newEmptyMVar writeChan c $ Left mv takeMVar mv type Line = String stdoutGateway :: (String, String) -> Chan (Either (MVar ()) (GmStream, String)) -> IO () stdoutGateway (outPf, errPf) chan = do runEffect $ commandProc >-> evalStateP ("","") seperateStreams where commandProc :: Producer (Either (MVar ()) (GmStream, String)) IO () commandProc = do cmd <- liftIO $ readChan chan case cmd of Left mv -> do yield $ Left mv Right input -> do yield $ Right input commandProc seperateStreams :: Consumer (Either (MVar ()) (GmStream, String)) (StateT (String, String) IO) () seperateStreams = do ecmd <- await case ecmd of Left mv -> do -- flush buffers (\s -> lift $ zoom (streamLens s) $ sGetLine Nothing) `mapM_` [GmOutStream, GmErrStream] liftIO $ putMVar mv () Right (stream, str) -> do ls <- lift $ zoom (streamLens stream) $ sGetLine (Just str) case ls of [] -> return () _ -> liftIO $ putStr $ unlines $ map (streamPf stream++) ls liftIO $ hFlush stdout seperateStreams sGetLine :: (Maybe String) -> StateT String IO [Line] sGetLine mstr' = do buf <- get let mstr = (buf++) `liftM` mstr' case mstr of Nothing -> put "" >> return [buf] Just "" -> return [] Just s | last s == '\n' -> put "" >> return (lines s) | otherwise -> do let (p:ls') = reverse $ lines s put p return $ reverse $ ls' streamLens GmOutStream = LB.fst streamLens GmErrStream = LB.snd streamPf GmOutStream = outPf streamPf GmErrStream = errPf zoom :: Monad m => (f L.:-> o) -> StateT o m a -> StateT f m a zoom l (StateT a) = StateT $ \f -> do (a', s') <- a $ L.get l f return (a', L.set l s' f) readProcessStderrChan :: (GmOut m, ProcessOutput a, NFData a) => m (FilePath -> [String] -> String -> IO a) readProcessStderrChan = do (_, e :: String -> IO ()) <- outputFns return $ readProcessStderrChan' e readProcessStderrChan' :: (ProcessOutput a, NFData a) => (String -> IO ()) -> FilePath -> [String] -> String -> IO a readProcessStderrChan' putErr exe args input = do let cp = (proc exe args) { std_out = CreatePipe , std_err = CreatePipe , std_in = CreatePipe } (Just i, Just o, Just e, h) <- createProcess cp _ <- forkIO $ reader e output <- hGetContents' o withForkWait (evaluate $ rnf output) $ \waitOut -> do -- now write any input unless (null input) $ ignoreSEx $ hPutStr i input -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE ignoreSEx $ hClose i -- wait on the output waitOut hClose o res <- waitForProcess h case res of ExitFailure rv -> throw $ GMEProcess "readProcessStderrChan" exe args $ Left rv ExitSuccess -> return output where ignoreSEx = handle (\(SomeException _) -> return ()) reader h = ignoreSEx $ do putErr . (++"\n") =<< hGetLine h reader h withForkWait :: IO () -> (IO () -> IO a) -> IO a withForkWait async body = do waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ())) mask $ \restore -> do tid <- forkIO $ try (restore async) >>= putMVar waitVar let wait = takeMVar waitVar >>= either throwIO return restore (body wait) `onException` killThread tid ghc-mod-5.8.0.0/core/GhcMod/PathsAndFiles.hs0000644000000000000000000001747713112432356016520 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . module GhcMod.PathsAndFiles ( module GhcMod.PathsAndFiles , module GhcMod.Caching ) where import Config (cProjectVersion) import Control.Arrow (second) import Control.Applicative import Control.Exception as E import Control.Monad import Control.Monad.Trans.Maybe import Data.List import Data.Char import Data.Maybe import Data.Traversable hiding (mapM) import Distribution.Helper (buildPlatform) import System.Directory import System.FilePath import System.Process import GhcMod.Types import GhcMod.Caching import qualified GhcMod.Utils as U import Utils (mightExist) import Prelude -- | Guaranteed to be a path to a directory with no trailing slash. type DirPath = FilePath -- | Guaranteed to be the name of a file only (no slashes). type FileName = String -- | @findCabalFiles dir@. Searches for a @.cabal@ files in @dir@'s parent -- directories. The first parent directory containing more than one cabal file -- is assumed to be the project directory. If only one cabal file exists in this -- directory it is returned otherwise @findCabalFiles@ throws 'GMENoCabalFile' -- or 'GMETooManyCabalFiles' findCabalFile :: FilePath -> IO (Maybe FilePath) findCabalFile dir = findFileInParentsP isCabalFile pick dir where pick [] = Nothing pick [cf] = Just cf pick cfs = throw $ GMETooManyCabalFiles cfs findStackConfigFile :: FilePath -> IO (Maybe FilePath) findStackConfigFile dir = findFileInParentsP (=="stack.yaml") pick dir where pick [] = Nothing pick (sf:_) = Just sf findCabalSandboxDir :: FilePath -> IO (Maybe FilePath) findCabalSandboxDir dir = fmap takeDirectory <$> findFileInParentsP isSandboxConfig pick dir where isSandboxConfig = (==sandboxConfigFileName) pick [] = Nothing pick (sc:_) = Just sc findCustomPackageDbFile :: FilePath -> IO (Maybe FilePath) findCustomPackageDbFile dir = mightExist $ dir "ghc-mod.package-db-stack" -- | Get path to sandbox config file getSandboxDb :: Cradle -> IO (Maybe GhcPkgDb) getSandboxDb crdl = do mConf <- traverse readFile =<< mightExist (sandboxConfigFile crdl) bp <- buildPlatform readProcess return $ PackageDb . fixPkgDbVer bp <$> (extractSandboxDbDir =<< mConf) where fixPkgDbVer bp dir = case takeFileName dir == ghcSandboxPkgDbDir bp of True -> dir False -> takeDirectory dir ghcSandboxPkgDbDir bp -- | Extract the sandbox package db directory from the cabal.sandbox.config -- file. Exception is thrown if the sandbox config file is broken. extractSandboxDbDir :: String -> Maybe FilePath extractSandboxDbDir conf = extractValue <$> parse conf where key = "package-db:" keyLen = length key parse = listToMaybe . filter (key `isPrefixOf`) . lines extractValue = U.dropWhileEnd isSpace . dropWhile isSpace . drop keyLen -- | -- >>> isCabalFile "/home/user/.cabal" -- False isCabalFile :: FilePath -> Bool isCabalFile f = takeExtension' f == ".cabal" -- | -- >>> takeExtension' "/some/dir/bla.cabal" -- ".cabal" -- -- >>> takeExtension' "some/reldir/bla.cabal" -- ".cabal" -- -- >>> takeExtension' "bla.cabal" -- ".cabal" -- -- >>> takeExtension' ".cabal" -- "" takeExtension' :: FilePath -> String takeExtension' p = if takeFileName p == takeExtension p then "" -- just ".cabal" is not a valid cabal file else takeExtension p -- | @findFileInParentsP p r dir@ Look for files satisfying @p@ in @dir@ and all -- it's parent directories. Files found to satisfy @p@ in a given directory are -- passed to @r@ and if this yields a 'Just' value the search finishes early -- without examinig any more directories and this value is returned. findFileInParentsP :: (FilePath -> Bool) -> ([FilePath] -> Maybe a) -> FilePath -> IO (Maybe a) findFileInParentsP p r dir = runMaybeT $ join $ msum <$> map (MaybeT . fmap r) <$> liftIO (findFilesInParentsP p dir) -- | @findFilesInParentsP p dir@ Look for files satisfying @p@ in @dir@ and all -- it's parent directories. findFilesInParentsP :: (FilePath -> Bool) -> FilePath -> IO [IO [FilePath]] findFilesInParentsP p dir' = U.makeAbsolute' dir' >>= \dir -> return $ map (\d -> (map (d )) <$> getFilesP p d) $ parents dir -- | @getFilesP p dir@. Find all __files__ satisfying @p@ in @.cabal@ in @dir@. getFilesP :: (FilePath -> Bool) -> DirPath -> IO [FileName] getFilesP p dir = filterM p' =<< getDirectoryContentsSafe where p' fn = do (p fn && ) <$> doesFileExist (dir fn) getDirectoryContentsSafe = do rdable <- readable <$> getPermissions dir if rdable then getDirectoryContents dir else return [] -- | @parents dir@. Returns all parent directories of @dir@ including @dir@. -- -- Examples -- -- >>> parents "foo" -- ["foo"] -- -- >>> parents "/foo" -- ["/foo","/"] -- -- >>> parents "/foo/bar" -- ["/foo/bar","/foo","/"] -- -- >>> parents "foo/bar" -- ["foo/bar","foo"] parents :: FilePath -> [FilePath] parents "" = [] parents dir' = let (drive, dir) = splitDrive $ normalise $ dropTrailingPathSeparator dir' in map (joinDrive drive) $ parents' $ filter (/=".") $ splitDirectories dir where parents' :: [String] -> [FilePath] parents' [] | isAbsolute dir' = "":[] parents' [] = [] parents' dir = [joinPath dir] ++ parents' (init dir) ---------------------------------------------------------------- setupConfigFile :: Cradle -> FilePath setupConfigFile crdl = cradleRootDir crdl setupConfigPath (cradleDistDir crdl) sandboxConfigFile :: Cradle -> FilePath sandboxConfigFile crdl = cradleRootDir crdl sandboxConfigFileName sandboxConfigFileName :: String sandboxConfigFileName = "cabal.sandbox.config" -- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@ setupConfigPath :: FilePath -> FilePath setupConfigPath dist = dist "setup-config" -- localBuildInfoFile defaultDistPref macrosHeaderPath :: FilePath macrosHeaderPath = autogenModulesDir "cabal_macros.h" autogenModulePath :: String -> String autogenModulePath pkg_name = autogenModulesDir ("Paths_" ++ map fixchar pkg_name) <.> ".hs" where fixchar '-' = '_' fixchar c = c autogenModulesDir :: FilePath autogenModulesDir = "build" "autogen" ghcSandboxPkgDbDir :: String -> String ghcSandboxPkgDbDir buildPlatf = do buildPlatf ++ "-ghc-" ++ cProjectVersion ++ "-packages.conf.d" packageCache :: String packageCache = "package.cache" -- | Filename of the symbol table cache file. symbolCache :: Cradle -> FilePath symbolCache crdl = cradleRootDir crdl cradleDistDir crdl symbolCacheFile symbolCacheFile :: String symbolCacheFile = "ghc-mod.symbol-cache" resolvedComponentsCacheFile :: FilePath -> FilePath resolvedComponentsCacheFile dist = setupConfigPath dist <.> "ghc-mod.resolved-components" cabalHelperCacheFile :: FilePath -> FilePath cabalHelperCacheFile dist = setupConfigPath dist <.> "ghc-mod.cabal-components" mergedPkgOptsCacheFile :: FilePath -> FilePath mergedPkgOptsCacheFile dist = setupConfigPath dist <.> "ghc-mod.package-options" pkgDbStackCacheFile :: FilePath -> FilePath pkgDbStackCacheFile dist = setupConfigPath dist <.> "ghc-mod.package-db-stack" ghc-mod-5.8.0.0/core/GhcMod/Pretty.hs0000644000000000000000000000525113112432356015305 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . module GhcMod.Pretty ( renderGm , renderSDoc , gmComponentNameDoc , gmLogLevelDoc , (<+>:) , fnDoc , showToDoc , warnDoc , strLnDoc , strDoc ) where import Control.Arrow hiding ((<+>)) import Data.Char import Data.List import Distribution.Helper import Pretty import GHC import Outputable (SDoc, withPprStyleDoc) import GhcMod.Types import GhcMod.Doc import GhcMod.Gap (renderGm) renderSDoc :: GhcMonad m => SDoc -> m Doc renderSDoc sdoc = do df <- getSessionDynFlags ppsty <- getStyle return $ withPprStyleDoc df ppsty sdoc gmComponentNameDoc :: ChComponentName -> Doc gmComponentNameDoc ChSetupHsName = text $ "Setup.hs" gmComponentNameDoc (ChLibName "") = text $ "library" gmComponentNameDoc (ChLibName n) = text $ "library:" ++ n gmComponentNameDoc (ChExeName n) = text $ "exe:" ++ n gmComponentNameDoc (ChTestName n) = text $ "test:" ++ n gmComponentNameDoc (ChBenchName n) = text $ "bench:" ++ n gmLogLevelDoc :: GmLogLevel -> Doc gmLogLevelDoc GmSilent = error "GmSilent MUST not be used for log messages" gmLogLevelDoc GmPanic = text "PANIC" gmLogLevelDoc GmException = text "EXCEPTION" gmLogLevelDoc GmError = text "ERROR" gmLogLevelDoc GmWarning = text "Warning" gmLogLevelDoc GmInfo = text "info" gmLogLevelDoc GmDebug = text "DEBUG" gmLogLevelDoc GmVomit = text "VOMIT" infixl 6 <+>: (<+>:) :: Doc -> Doc -> Doc a <+>: b = (a <> colon) <+> b fnDoc :: FilePath -> Doc fnDoc = doubleQuotes . text showToDoc :: Show a => a -> Doc showToDoc = strLnDoc . show warnDoc :: Doc -> Doc warnDoc d = text "Warning" <+>: d strLnDoc :: String -> Doc strLnDoc str = doc (dropWhileEnd isSpace str) where doc = lines >>> map text >>> foldr ($+$) empty strDoc :: String -> Doc strDoc str = doc (dropWhileEnd isSpace str) where doc :: String -> Doc doc = lines >>> map (words >>> map text >>> fsep) >>> \l -> case l of (x:xs) -> hang x 4 (vcat xs); [] -> empty ghc-mod-5.8.0.0/core/GhcMod/Read.hs0000644000000000000000000001112713112432356014670 0ustar0000000000000000module 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 ghc-mod-5.8.0.0/core/GhcMod/SrcUtils.hs0000644000000000000000000001735513112432356015576 0ustar0000000000000000-- 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 ghc-mod-5.8.0.0/core/GhcMod/Stack.hs0000644000000000000000000000670513112432356015070 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . module GhcMod.Stack where import Safe import Control.Applicative import Control.Exception as E import Control.Monad import Control.Monad.Trans.Maybe import Control.Monad.Trans.Class import Data.List import Data.List.Split import Data.Maybe import System.Directory import System.FilePath import System.Info.Extra import Exception import GhcMod.Types import GhcMod.Monad.Types import GhcMod.Output import GhcMod.Logging import GhcMod.Error import qualified GhcMod.Utils as U import Prelude patchStackPrograms :: (IOish m, GmOut m) => Cradle -> Programs -> m Programs patchStackPrograms Cradle { cradleProject = (StackProject senv) } progs = do Just ghc <- getStackGhcPath senv Just ghcPkg <- getStackGhcPkgPath senv return $ progs { ghcProgram = ghc , ghcPkgProgram = ghcPkg } patchStackPrograms _crdl progs = return progs getStackEnv :: (IOish m, GmOut m, GmLog m) => FilePath -> FilePath -> m (Maybe StackEnv) getStackEnv projdir stackProg = U.withDirectory_ projdir $ runMaybeT $ do env <- map (liToTup . splitOn ": ") . lines <$> readStack stackProg ["path"] let look k = fromJustNote "getStackEnv" $ lookup k env return StackEnv { seDistDir = look "dist-dir" , seBinPath = splitSearchPath $ look "bin-path" , seSnapshotPkgDb = look "snapshot-pkg-db" , seLocalPkgDb = look "local-pkg-db" } where liToTup [k,v] = (k,v) liToTup [k] = (k, error "getStackEnv: missing key '"++k++"'") liToTup _ = error "getStackEnv" getStackGhcPath :: IOish m => StackEnv -> m (Maybe FilePath) getStackGhcPath = findExecutablesInStackBinPath "ghc" getStackGhcPkgPath :: IOish m => StackEnv -> m (Maybe FilePath) getStackGhcPkgPath = findExecutablesInStackBinPath "ghc-pkg" findExecutablesInStackBinPath :: IOish m => String -> StackEnv -> m (Maybe FilePath) findExecutablesInStackBinPath exe StackEnv {..} = liftIO $ listToMaybe <$> findExecutablesInDirectories' seBinPath exe findExecutablesInDirectories' :: [FilePath] -> String -> IO [FilePath] findExecutablesInDirectories' path binary = U.findFilesWith' isExecutable path (binary <.> exeExtension') where isExecutable file = do perms <- getPermissions file return $ executable perms exeExtension' = if isWindows then "exe" else "" readStack :: (IOish m, GmOut m, GmLog m) => FilePath -> [String] -> MaybeT m String readStack exe args = do stack <- MaybeT $ liftIO $ findExecutable exe readProc <- lift gmReadProcess flip gcatch handler $ do liftIO $ evaluate =<< readProc stack args "" where handler (e :: IOError) = do gmLog GmWarning "readStack" $ gmeDoc $ exToErr e mzero exToErr = GMEStackBootstrap . GMEString . show ghc-mod-5.8.0.0/core/GhcMod/Target.hs0000644000000000000000000004433613112432356015253 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE CPP, ViewPatterns, NamedFieldPuns, RankNTypes #-} module GhcMod.Target where import Control.Arrow import Control.Applicative import Control.Category ((.)) import GHC #if __GLASGOW_HASKELL__ >= 800 import GHC.LanguageExtensions #endif import GHC.Paths (libdir) import SysTools import DynFlags import HscTypes import Pretty import GhcMod.DynFlags import GhcMod.Monad.Types import GhcMod.CabalHelper import GhcMod.HomeModuleGraph import GhcMod.PathsAndFiles import GhcMod.GhcPkg import GhcMod.Error import GhcMod.Logging import GhcMod.Types import GhcMod.Utils as U import GhcMod.FileMapping import GhcMod.LightGhc import GhcMod.CustomPackageDb import GhcMod.Output import Safe import Data.Maybe import Data.Monoid as Monoid import Data.Either import Data.Foldable as Foldable (foldrM) import qualified Data.Foldable as Foldable import Data.Traversable hiding (mapM, forM) import Data.IORef import Data.List import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import Data.Function (on) import Distribution.Helper import Prelude hiding ((.)) import System.Directory import System.FilePath runGmPkgGhc :: (IOish m, Gm m) => LightGhc a -> m a runGmPkgGhc action = do pkgOpts <- packageGhcOptions withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action initSession :: IOish m => [GHCOption] -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags) -> GhcModT m () initSession opts mdf = do s <- gmsGet case gmGhcSession s of Nothing -> do gmLog GmDebug "initSession" $ text "Session not initialized, creating new one" putNewSession s Just (GmGhcSession hsc_env_ref) -> do crdl <- cradle df <- liftIO $ hsc_dflags <$> readIORef hsc_env_ref changed <- withLightHscEnv' (initDF crdl) $ \hsc_env -> return $ not $ hsc_dflags hsc_env `eqDynFlags` df if changed then do gmLog GmDebug "initSession" $ text "Flags changed, creating new session" teardownSession hsc_env_ref putNewSession s else gmLog GmDebug "initSession" $ text "Session already initialized" where initDF Cradle { cradleTempDir } df = setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df) teardownSession hsc_env_ref = do hsc_env <- liftIO $ readIORef hsc_env_ref teardownLightEnv hsc_env putNewSession :: IOish m => GhcModState -> GhcModT m () putNewSession s = do crdl <- cradle nhsc_env_ref <- liftIO . newIORef =<< newLightEnv (initDF crdl) runLightGhc' nhsc_env_ref $ setSessionDynFlags =<< getSessionDynFlags gmsPut s { gmGhcSession = Just $ GmGhcSession nhsc_env_ref } -- | Drop the currently active GHC session, the next that requires a GHC session -- will initialize a new one. dropSession :: IOish m => GhcModT m () dropSession = do s <- gmsGet case gmGhcSession s of Just (GmGhcSession ref) -> do -- TODO: This is still not enough, there seem to still be references to -- GHC's state around afterwards. liftIO $ writeIORef ref (error "HscEnv: session was dropped") -- Not available on ghc<7.8; didn't really help anyways -- liftIO $ setUnsafeGlobalDynFlags (error "DynFlags: session was dropped") gmsPut s { gmGhcSession = Nothing } Nothing -> return () -- | Run a GmlT action (i.e. a function in the GhcMonad) in the context -- of certain files or modules runGmlT :: IOish m => [Either FilePath ModuleName] -> GmlT m a -> GhcModT m a runGmlT fns action = runGmlT' fns return action -- | Run a GmlT action (i.e. a function in the GhcMonad) in the context -- of certain files or modules, with updated GHC flags runGmlT' :: IOish m => [Either FilePath ModuleName] -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags) -> GmlT m a -> GhcModT m a runGmlT' fns mdf action = runGmlTWith fns mdf id action -- | Run a GmlT action (i.e. a function in the GhcMonad) in the context -- of certain files or modules, with updated GHC flags and a final -- transformation runGmlTWith :: IOish m => [Either FilePath ModuleName] -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags) -> (GmlT m a -> GmlT m b) -> GmlT m a -> GhcModT m b runGmlTWith efnmns' mdf wrapper action = do crdl <- cradle Options { optGhcUserOptions } <- options let (fns, mns) = partitionEithers efnmns' ccfns = map (cradleCurrentDir crdl ) fns cfns <- mapM getCanonicalFileNameSafe ccfns let serfnmn = Set.fromList $ map Right mns ++ map Left cfns opts <- targetGhcOptions crdl serfnmn let opts' = opts ++ ["-O0"] ++ optGhcUserOptions gmVomit "session-ghc-options" (text "Initializing GHC session with following options") (intercalate " " $ map (("\""++) . (++"\"")) opts') GhcModLog { gmLogLevel = Just level } <- gmlHistory putErr <- gmErrStrIO let setLogger | level >= GmDebug = setDebugLogger putErr | otherwise = setEmptyLogger initSession opts' $ setHscNothing >>> setLogger >>> mdf mappedStrs <- getMMappedFilePaths let targetStrs = mappedStrs ++ map moduleNameString mns ++ cfns unGmlT $ wrapper $ do loadTargets opts targetStrs action targetGhcOptions :: forall m. IOish m => Cradle -> Set (Either FilePath ModuleName) -> GhcModT m [GHCOption] targetGhcOptions crdl sefnmn = do when (Set.null sefnmn) $ error "targetGhcOptions: no targets given" case cradleProject crdl of proj | isCabalHelperProject proj -> cabalOpts crdl | otherwise -> sandboxOpts crdl where zipMap f l = l `zip` (f `map` l) cabalOpts :: Cradle -> GhcModT m [String] cabalOpts Cradle{..} = do mcs <- cabalResolvedComponents let mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn candidates = findCandidates $ map snd mdlcs let noCandidates = Set.null candidates noModuleHasAnyAssignment = all (Set.null . snd) mdlcs if noCandidates && noModuleHasAnyAssignment then do -- First component should be ChLibName, if no lib will take lexically first exe. let cns = filter (/= ChSetupHsName) $ Map.keys mcs gmLog GmDebug "" $ strDoc $ "Could not find a component assignment, falling back to picking library component in cabal file." return $ gmcGhcOpts $ fromJustNote "targetGhcOptions, no-assignment" $ Map.lookup (head cns) mcs else do when noCandidates $ throwError $ GMECabalCompAssignment mdlcs let cn = pickComponent candidates return $ gmcGhcOpts $ fromJustNote "targetGhcOptions" $ Map.lookup cn mcs resolvedComponentsCache :: IOish m => FilePath -> Cached (GhcModT m) GhcModState [GmComponent 'GMCRaw (Set.Set ModulePath)] (Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath))) resolvedComponentsCache distdir = Cached { cacheLens = Just (lGmcResolvedComponents . lGmCaches), cacheFile = resolvedComponentsCacheFile distdir, cachedAction = \tcfs comps ma -> do Cradle {..} <- cradle let iifs = invalidatingInputFiles tcfs setupChanged = (cradleRootDir setupConfigPath distdir) `elem` iifs mums :: Maybe [Either FilePath ModuleName] mums = let filterOutSetupCfg = filter (/= cradleRootDir setupConfigPath distdir) changedFiles = filterOutSetupCfg iifs in if null changedFiles || setupChanged then Nothing else Just $ map Left changedFiles let mdesc (Left f) = "file:" ++ f mdesc (Right mn) = "module:" ++ moduleNameString mn changed = map (text . mdesc) $ Foldable.concat mums changedDoc | [] <- changed = text "none" | otherwise = sep changed gmLog GmDebug "resolvedComponentsCache" $ text "files changed" <+>: changedDoc mcs <- resolveGmComponents ((,) <$> mums <*> ma) comps return (setupConfigPath distdir : flatten mcs , mcs) } where flatten :: Map.Map ChComponentName (GmComponent t (Set.Set ModulePath)) -> [FilePath] flatten = Map.elems >>> map (gmcHomeModuleGraph >>> gmgGraph >>> (Map.keysSet &&& Map.elems) >>> uncurry insert >>> map (Set.map mpPath) >>> Set.unions ) >>> Set.unions >>> Set.toList moduleComponents :: Map ChComponentName (GmComponent t (Set ModulePath)) -> Either FilePath ModuleName -> Set ChComponentName moduleComponents m efnmn = foldr' Set.empty m $ \c s -> let memb = case efnmn of Left fn -> fn `Set.member` Set.map mpPath (smp c) Right mn -> mn `Set.member` Set.map mpModule (smp c) in if memb then Set.insert (gmcName c) s else s where smp c = Map.keysSet $ gmgGraph $ gmcHomeModuleGraph c foldr' b as f = Map.foldr f b as findCandidates :: [Set ChComponentName] -> Set ChComponentName findCandidates [] = Set.empty findCandidates scns = foldl1 Set.intersection scns pickComponent :: Set ChComponentName -> ChComponentName pickComponent scn = Set.findMin scn packageGhcOptions :: (IOish m, Applicative m, Gm m) => m [GHCOption] packageGhcOptions = do crdl <- cradle case cradleProject crdl of proj | isCabalHelperProject proj -> getGhcMergedPkgOptions | otherwise -> sandboxOpts crdl -- also works for plain projects! sandboxOpts :: (IOish m, GmEnv m) => Cradle -> m [String] sandboxOpts crdl = do mCusPkgDb <- getCustomPkgDbStack pkgDbStack <- liftIO $ getSandboxPackageDbStack let pkgOpts = ghcDbStackOpts $ fromMaybe pkgDbStack mCusPkgDb return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts ++ ["-Wall"] where (wdir, rdir) = (cradleCurrentDir crdl, cradleRootDir crdl) getSandboxPackageDbStack :: IO [GhcPkgDb] getSandboxPackageDbStack = ([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb crdl resolveGmComponent :: (IOish m, Gm m) => Maybe [CompilationUnit] -- ^ Updated modules -> GmComponent 'GMCRaw (Set ModulePath) -> m (GmComponent 'GMCResolved (Set ModulePath)) resolveGmComponent mums c@GmComponent {..} = do distDir <- cradleDistDir <$> cradle gmLog GmDebug "resolveGmComponent" $ text $ show $ ghcOpts distDir withLightHscEnv (ghcOpts distDir) $ \env -> do let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs let mg = gmcHomeModuleGraph let simp = gmcEntrypoints sump <- case mums of Nothing -> return simp Just ums -> Set.fromList . catMaybes <$> mapM (resolveModule env srcDirs) ums mg' <- canonicalizeModuleGraph =<< updateHomeModuleGraph env mg simp sump return $ c { gmcEntrypoints = simp, gmcHomeModuleGraph = mg' } where ghcOpts distDir = concat [ gmcGhcSrcOpts, gmcGhcLangOpts, [ "-optP-include", "-optP" ++ distDir macrosHeaderPath ] ] resolveEntrypoint :: (IOish m, Gm m) => Cradle -> GmComponent 'GMCRaw ChEntrypoint -> m (GmComponent 'GMCRaw (Set ModulePath)) resolveEntrypoint Cradle {..} c@GmComponent {..} = do gmLog GmDebug "resolveEntrypoint" $ text $ show $ gmcGhcSrcOpts withLightHscEnv gmcGhcSrcOpts $ \env -> do let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs eps <- liftIO $ resolveChEntrypoints cradleRootDir gmcEntrypoints rms <- resolveModule env srcDirs `mapM` eps return c { gmcEntrypoints = Set.fromList $ catMaybes rms } -- TODO: remember that the file from `main-is:` is always module `Main` and let -- ghc do the warning about it. Right now we run that module through -- resolveModule like any other resolveChEntrypoints :: FilePath -> ChEntrypoint -> IO [CompilationUnit] resolveChEntrypoints _ (ChLibEntrypoint em om) = return $ map (Right . chModToMod) (em ++ om) resolveChEntrypoints _ (ChExeEntrypoint main om) = return $ [Left main] ++ map (Right . chModToMod) om resolveChEntrypoints srcDir ChSetupEntrypoint = do shs <- doesFileExist (srcDir "Setup.hs") slhs <- doesFileExist (srcDir "Setup.lhs") return $ case (shs, slhs) of (True, _) -> [Left "Setup.hs"] (_, True) -> [Left "Setup.lhs"] (False, False) -> [] chModToMod :: ChModuleName -> ModuleName chModToMod (ChModuleName mn) = mkModuleName mn resolveModule :: (IOish m, Gm m) => HscEnv -> [FilePath] -> CompilationUnit -> m (Maybe ModulePath) resolveModule env _srcDirs (Right mn) = liftIO $ traverse canonicalizeModulePath =<< findModulePath env mn resolveModule env srcDirs (Left fn') = do mfn <- liftIO $ findFile' srcDirs fn' case mfn of Nothing -> return Nothing Just fn'' -> do fn <- liftIO $ canonicalizePath fn'' emn <- fileModuleName env fn case emn of Left errs -> do gmLog GmWarning ("resolveModule " ++ show fn) $ Pretty.empty $+$ (vcat $ map text errs) return Nothing -- TODO: should expose these errors otherwise -- modules with preprocessor/parse errors are -- going to be missing Right mmn -> return $ Just $ case mmn of Nothing -> mkMainModulePath fn Just mn -> ModulePath mn fn where -- needed for ghc 7.4 findFile' dirs file = getFirst . mconcat <$> mapM (fmap First . mightExist . (file)) dirs -- fileModuleName fn (dir:dirs) -- | makeRelative dir fn /= fn type CompilationUnit = Either FilePath ModuleName type Components = [GmComponent 'GMCRaw (Set ModulePath)] type ResolvedComponentsMap = Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath)) resolveGmComponents :: (IOish m, Gm m) => Maybe ([CompilationUnit], ResolvedComponentsMap) -- ^ Updated modules -> Components -> m ResolvedComponentsMap resolveGmComponents mcache cs = do let rcm = fromMaybe Map.empty $ snd <$> mcache m' <- foldrM' rcm cs $ \c m -> do case Map.lookup (gmcName c) m of Nothing -> insertUpdated m c Just c' -> if same gmcRawEntrypoints c c' && same gmcGhcSrcOpts c c' then return m else insertUpdated m c return m' where foldrM' b fa f = foldrM f b fa insertUpdated m c = do rc <- resolveGmComponent (fst <$> mcache) c return $ Map.insert (gmcName rc) rc m same :: Eq b => (forall t a. GmComponent t a -> b) -> GmComponent u c -> GmComponent v d -> Bool same f a b = (f a) == (f b) -- | Set the files as targets and load them. loadTargets :: IOish m => [GHCOption] -> [FilePath] -> GmlT m () loadTargets opts targetStrs = do targets' <- withLightHscEnv opts $ \env -> liftM (nubBy ((==) `on` targetId)) (mapM ((`guessTarget` Nothing) >=> mapFile env) targetStrs) >>= mapM relativize let targets = map (\t -> t { targetAllowObjCode = False }) targets' gmLog GmDebug "loadTargets" $ text "Loading" <+>: fsep (map (text . showTargetId) targets) setTargets targets mg <- depanal [] False let interp = needsHscInterpreted mg target <- hscTarget <$> getSessionDynFlags when (interp && target /= HscInterpreted) $ do _ <- setSessionDynFlags . setHscInterpreted =<< getSessionDynFlags gmLog GmInfo "loadTargets" $ text "Target needs interpeter, switching to LinkInMemory/HscInterpreted. Perfectly normal if anything is using TemplateHaskell, QuasiQuotes or PatternSynonyms." target' <- hscTarget <$> getSessionDynFlags case target' of HscNothing -> do void $ load LoadAllTargets forM_ mg $ handleSourceError (gmLog GmDebug "loadTargets" . text . show) . void . (parseModule >=> typecheckModule >=> desugarModule) HscInterpreted -> do void $ load LoadAllTargets _ -> error ("loadTargets: unsupported hscTarget") gmLog GmDebug "loadTargets" $ text "Loading done" where relativize (Target (TargetFile filePath phase) taoc src) = do crdl <- cradle let tid = TargetFile relativeFilePath phase relativeFilePath = makeRelative (cradleRootDir crdl) filePath return $ Target tid taoc src relativize tgt = return tgt showTargetId (Target (TargetModule s) _ _) = moduleNameString s showTargetId (Target (TargetFile s _) _ _) = s needsHscInterpreted :: ModuleGraph -> Bool needsHscInterpreted = any $ \ms -> let df = ms_hspp_opts ms in #if __GLASGOW_HASKELL__ >= 800 TemplateHaskell `xopt` df || QuasiQuotes `xopt` df || PatternSynonyms `xopt` df #else Opt_TemplateHaskell `xopt` df || Opt_QuasiQuotes `xopt` df #if __GLASGOW_HASKELL__ >= 708 || (Opt_PatternSynonyms `xopt` df) #endif #endif cabalResolvedComponents :: (IOish m) => GhcModT m (Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath))) cabalResolvedComponents = do crdl@(Cradle{..}) <- cradle comps <- mapM (resolveEntrypoint crdl) =<< getComponents withAutogen $ cached cradleRootDir (resolvedComponentsCache cradleDistDir) comps ghc-mod-5.8.0.0/core/GhcMod/Types.hs0000644000000000000000000003016013112432356015117 0ustar0000000000000000{-# 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 ghc-mod-5.8.0.0/core/GhcMod/Utils.hs0000644000000000000000000001273613112432356015124 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE CPP #-} {-# LANGUAGE DoAndIfThenElse #-} module GhcMod.Utils ( module GhcMod.Utils , module Utils , readProcess ) where import Control.Applicative import Data.Char import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Either (rights) import Data.List (inits) import Exception import GhcMod.Error import GhcMod.Types import GhcMod.Monad.Types import System.Directory import System.Environment import System.FilePath import System.IO.Temp (createTempDirectory) import System.Process (readProcess) import Text.Printf import Paths_ghc_mod (getLibexecDir, getBinDir) import Utils import Prelude -- dropWhileEnd is not provided prior to base 4.5.0.0. dropWhileEnd :: (a -> Bool) -> [a] -> [a] dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) [] withDirectory_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a withDirectory_ dir action = gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory) (\_ -> liftIO (setCurrentDirectory dir) >> action) uniqTempDirName :: FilePath -> FilePath uniqTempDirName dir = "ghc-mod" ++ map escapeDriveChar drive ++ map escapePathChar path where (drive, path) = splitDrive dir escapeDriveChar :: Char -> Char escapeDriveChar c | isAlphaNum c = c | otherwise = '-' escapePathChar :: Char -> Char escapePathChar c | c `elem` pathSeparators = '-' | otherwise = c newTempDir :: FilePath -> IO FilePath newTempDir _dir = flip createTempDirectory "ghc-mod" =<< getTemporaryDirectory whenM :: Monad m => m Bool -> m () -> m () whenM mb ma = mb >>= flip when ma -- | Returns the path to the currently running ghc-mod executable. With ghc<7.6 -- this is a guess but >=7.6 uses 'getExecutablePath'. ghcModExecutable :: IO FilePath ghcModExecutable = do exe <- getExecutablePath' stack <- lookupEnv "STACK_EXE" case takeBaseName exe of "spec" | Just _ <- stack -> ( "ghc-mod") <$> getBinDir "spec" -> ( "dist/build/ghc-mod/ghc-mod") <$> getCurrentDirectory "ghc-mod" -> return exe _ -> return $ takeDirectory exe "ghc-mod" getExecutablePath' :: IO FilePath #if __GLASGOW_HASKELL__ >= 706 getExecutablePath' = getExecutablePath #else getExecutablePath' = getProgName #endif canonFilePath :: FilePath -> IO FilePath canonFilePath f = do p <- canonicalizePath f e <- doesFileExist p when (not e) $ error $ "canonFilePath: not a file: " ++ p return p withMappedFile :: (IOish m, GmState m, GmEnv m) => forall a. FilePath -> (FilePath -> m a) -> m a withMappedFile file action = getCanonicalFileNameSafe file >>= lookupMMappedFile >>= runWithFile where runWithFile (Just to) = action $ fmPath to runWithFile _ = action file getCanonicalFileNameSafe :: (IOish m, GmEnv m) => FilePath -> m FilePath getCanonicalFileNameSafe fn = do let fn' = normalise fn pl <- liftIO $ rights <$> (mapM ((try :: IO FilePath -> IO (Either SomeException FilePath)) . canonicalizePath . joinPath) $ reverse $ inits $ splitPath' fn') return $ if (length pl > 0) then joinPath $ (head pl):(drop (length pl - 1) (splitPath fn')) else error "Current dir doesn't seem to exist?" where #if __GLASGOW_HASKELL__ < 710 splitPath' = (".":) . splitPath #else splitPath' = splitPath #endif mkRevRedirMapFunc :: (Functor m, GmState m, GmEnv m) => m (FilePath -> FilePath) mkRevRedirMapFunc = do rm <- M.fromList <$> map (uncurry mf) <$> M.toList <$> getMMappedFiles crdl <- cradle return $ \key -> fromMaybe key $ makeRelative (cradleRootDir crdl) <$> M.lookup key rm where mf :: FilePath -> FileMapping -> (FilePath, FilePath) mf from to = (fmPath to, from) findFilesWith' :: (FilePath -> IO Bool) -> [FilePath] -> String -> IO [FilePath] findFilesWith' _ [] _ = return [] findFilesWith' f (d:ds) fileName = do let file = d fileName exist <- doesFileExist file b <- if exist then f file else return False if b then do files <- findFilesWith' f ds fileName return $ file : files else findFilesWith' f ds fileName -- Copyright : (c) The University of Glasgow 2001 -- | Make a path absolute by prepending the current directory (if it isn't -- already absolute) and applying 'normalise' to the result. -- -- If the path is already absolute, the operation never fails. Otherwise, the -- operation may fail with the same exceptions as 'getCurrentDirectory'. makeAbsolute' :: FilePath -> IO FilePath makeAbsolute' = (normalise <$>) . absolutize where absolutize path -- avoid the call to `getCurrentDirectory` if we can | isRelative path = ( path) <$> getCurrentDirectory | otherwise = return path ghc-mod-5.8.0.0/core/GhcMod/World.hs0000644000000000000000000000320613112432356015103 0ustar0000000000000000module 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 ghc-mod-5.8.0.0/core/GhcMod/Caching/0000755000000000000000000000000013112432356015013 5ustar0000000000000000ghc-mod-5.8.0.0/core/GhcMod/Caching/Types.hs0000644000000000000000000000446313112432356016462 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . module GhcMod.Caching.Types where import Utils import Data.Label import System.Directory.ModTime import Distribution.Helper type CacheContents d a = Maybe (ModTime, [FilePath], d, a) type CacheLens s d a = s :-> CacheContents d a data Cached m s d a = Cached { cacheFile :: FilePath, cacheLens :: Maybe (CacheLens s d a), cachedAction :: TimedCacheFiles -> d -> Maybe a -> m ([FilePath], a) -- ^ @cachedAction tcf data ma@ -- -- * @tcf@: Input file timestamps. Not technically necessary, just an -- optimizazion when knowing which input files changed can make updating the -- cache faster -- -- * @data@: Arbitrary static input data to cache action. Can be used to -- invalidate the cache using something other than file timestamps -- i.e. environment tool version numbers -- -- * @ma@: Cached data if it existed -- -- Returns: -- -- * @fst@: Input files used in generating the cache -- -- * @snd@: Cache data, will be stored alongside the static input data in the -- 'cacheFile' -- -- The cached action, will only run if one of the following is true: -- -- * 'cacheFile' doesn\'t exist yet -- * 'cacheFile' exists and 'inputData' changed -- * any files returned by the cached action changed } data TimedCacheFiles = TimedCacheFiles { tcCreated :: ModTime, -- ^ 'cacheFile' timestamp tcFiles :: [TimedFile] -- ^ Timestamped files returned by the cached action } deriving (Eq, Ord) type ChCacheData = (Programs, FilePath, (String, String)) ghc-mod-5.8.0.0/core/GhcMod/Monad/0000755000000000000000000000000013112432356014515 5ustar0000000000000000ghc-mod-5.8.0.0/core/GhcMod/Monad/Env.hs0000644000000000000000000000453713112432356015612 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015,2016 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} {-# LANGUAGE FlexibleInstances, UndecidableInstances #-} module GhcMod.Monad.Env where import GhcMod.Types import GhcMod.Monad.Newtypes import Control.Monad import Control.Monad.Trans.Journal (JournalT) import Control.Monad.State.Strict (StateT(..)) import Control.Monad.Error (ErrorT(..)) import Control.Monad.Reader.Class import Control.Monad.Trans.Class (MonadTrans(..)) import Prelude class Monad m => GmEnv m where gmeAsk :: m GhcModEnv gmeAsk = gmeReader id gmeReader :: (GhcModEnv -> a) -> m a gmeReader f = f `liftM` gmeAsk gmeLocal :: (GhcModEnv -> GhcModEnv) -> m a -> m a {-# MINIMAL (gmeAsk | gmeReader), gmeLocal #-} instance Monad m => GmEnv (GmT m) where gmeAsk = GmT ask gmeReader = GmT . reader gmeLocal f a = GmT $ local f (unGmT a) instance GmEnv m => GmEnv (GmOutT m) where gmeAsk = lift gmeAsk gmeReader = lift . gmeReader gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma)) instance GmEnv m => GmEnv (StateT s m) where gmeAsk = lift gmeAsk gmeReader = lift . gmeReader gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma)) instance GmEnv m => GmEnv (JournalT GhcModLog m) where gmeAsk = lift gmeAsk gmeReader = lift . gmeReader gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma)) instance GmEnv m => GmEnv (ErrorT GhcModError m) where gmeAsk = lift gmeAsk gmeReader = lift . gmeReader gmeLocal f ma = gmLiftWithInner (\run -> gmeLocal f (run ma)) deriving instance (Monad m, GmEnv (GhcModT m)) => GmEnv (GmlT m) ghc-mod-5.8.0.0/core/GhcMod/Monad/Log.hs0000644000000000000000000000471113112432356015575 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015,2016 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} {-# LANGUAGE FlexibleInstances, UndecidableInstances #-} module GhcMod.Monad.Log where import GhcMod.Types import GhcMod.Monad.Newtypes import Control.Monad import Control.Monad.Trans.Journal (JournalT) import Control.Monad.Reader (ReaderT(..)) import Control.Monad.State.Strict (StateT(..)) import Control.Monad.Error (Error, ErrorT(..)) import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Journal.Class (MonadJournal(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import Prelude class Monad m => GmLog m where gmlJournal :: GhcModLog -> m () gmlHistory :: m GhcModLog gmlClear :: m () instance Monad m => GmLog (JournalT GhcModLog m) where gmlJournal = journal gmlHistory = history gmlClear = clear instance Monad m => GmLog (GmT m) where gmlJournal = GmT . lift . lift . journal gmlHistory = GmT $ lift $ lift history gmlClear = GmT $ lift $ lift clear instance (Monad m, GmLog m) => GmLog (ReaderT r m) where gmlJournal = lift . gmlJournal gmlHistory = lift gmlHistory gmlClear = lift gmlClear instance (Monad m, GmLog m) => GmLog (StateT s m) where gmlJournal = lift . gmlJournal gmlHistory = lift gmlHistory gmlClear = lift gmlClear instance (Monad m, GmLog m, Error e) => GmLog (ErrorT e m) where gmlJournal = lift . gmlJournal gmlHistory = lift gmlHistory gmlClear = lift gmlClear instance (Monad m, GmLog m) => GmLog (MaybeT m) where gmlJournal = lift . gmlJournal gmlHistory = lift gmlHistory gmlClear = lift gmlClear deriving instance GmLog m => GmLog (GmOutT m) deriving instance (Monad m, GmLog (GhcModT m)) => GmLog (GmlT m) ghc-mod-5.8.0.0/core/GhcMod/Monad/Newtypes.hs0000644000000000000000000001322213112432356016667 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015,2016 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE CPP, GeneralizedNewtypeDeriving, DeriveFunctor #-} {-# LANGUAGE MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-} {-# LANGUAGE RankNTypes, FlexibleInstances #-} module GhcMod.Monad.Newtypes where #include "Compat.hs_h" import GhcMod.Types import GHC import Control.Applicative import Control.Monad import Control.Monad.Reader (ReaderT(..)) import Control.Monad.Error (ErrorT(..), MonadError(..)) import Control.Monad.State.Strict (StateT(..)) import Control.Monad.Trans.Journal (JournalT) import Control.Monad.Reader.Class import Control.Monad.State.Class (MonadState(..)) import Control.Monad.Journal.Class (MonadJournal(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Control import Control.Monad.Base (MonadBase(..), liftBase) import Data.IORef import Prelude type GhcModT m = GmT (GmOutT m) newtype GmOutT m a = GmOutT { unGmOutT :: ReaderT GhcModOut m a } deriving ( Functor , Applicative , Alternative , Monad , MonadPlus , MonadTrans ) newtype GmT m a = GmT { unGmT :: StateT GhcModState (ErrorT GhcModError (JournalT GhcModLog (ReaderT GhcModEnv m) ) ) a } deriving ( Functor , Applicative , Alternative , Monad , MonadPlus , MonadError GhcModError ) newtype GmlT m a = GmlT { unGmlT :: GhcModT m a } deriving ( Functor , Applicative , Alternative , Monad , MonadPlus , MonadError GhcModError ) newtype LightGhc a = LightGhc { unLightGhc :: ReaderT (IORef HscEnv) IO a } deriving ( Functor , Applicative , Monad ) -- GmOutT ---------------------------------------- instance (MonadBaseControl IO m) => MonadBase IO (GmOutT m) where liftBase = GmOutT . liftBase instance (MonadBaseControl IO m) => MonadBaseControl IO (GmOutT m) where type StM (GmOutT m) a = StM (ReaderT GhcModEnv m) a liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM {-# INLINE liftBaseWith #-} {-# INLINE restoreM #-} instance MonadTransControl GmOutT where type StT GmOutT a = StT (ReaderT GhcModEnv) a liftWith = defaultLiftWith GmOutT unGmOutT restoreT = defaultRestoreT GmOutT -- GmlT ------------------------------------------ instance (MonadBaseControl IO m) => MonadBase IO (GmlT m) where liftBase = GmlT . liftBase instance (MonadBaseControl IO m) => MonadBaseControl IO (GmlT m) where type StM (GmlT m) a = StM (GmT m) a liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM {-# INLINE liftBaseWith #-} {-# INLINE restoreM #-} instance MonadTransControl GmlT where type StT GmlT a = StT GmT a liftWith f = GmlT $ liftWith $ \runGm -> liftWith $ \runEnv -> f $ \ma -> runEnv $ runGm $ unGmlT ma restoreT = GmlT . restoreT . restoreT instance MonadTrans GmlT where lift = GmlT . lift . lift -- GmT ------------------------------------------ instance MonadReader r m => MonadReader r (GmT m) where local f ma = gmLiftWithInner (\run -> local f (run ma)) ask = gmLiftInner ask instance MonadState s m => MonadState s (GmT m) where get = GmT $ lift $ lift $ lift get put = GmT . lift . lift . lift . put state = GmT . lift . lift . lift . state instance Monad m => MonadJournal GhcModLog (GmT m) where journal w = GmT $ lift $ lift $ (journal w) history = GmT $ lift $ lift $ history clear = GmT $ lift $ lift $ clear instance (MonadBaseControl IO m) => MonadBase IO (GmT m) where liftBase = GmT . liftBase instance (MonadBaseControl IO m) => MonadBaseControl IO (GmT m) where type StM (GmT m) a = StM (StateT GhcModState (ErrorT GhcModError (JournalT GhcModLog (ReaderT GhcModEnv m) ) ) ) a liftBaseWith f = GmT (liftBaseWith $ \runInBase -> f $ runInBase . unGmT) restoreM = GmT . restoreM {-# INLINE liftBaseWith #-} {-# INLINE restoreM #-} instance MonadTransControl GmT where type StT GmT a = (Either GhcModError (a, GhcModState), GhcModLog) liftWith f = GmT $ liftWith $ \runS -> liftWith $ \runE -> liftWith $ \runJ -> liftWith $ \runR -> f $ \ma -> runR $ runJ $ runE $ runS $ unGmT ma restoreT = GmT . restoreT . restoreT . restoreT . restoreT {-# INLINE liftWith #-} {-# INLINE restoreT #-} instance MonadTrans GmT where lift = GmT . lift . lift . lift . lift gmLiftInner :: Monad m => m a -> GmT m a gmLiftInner = GmT . lift . lift . lift . lift gmLiftWithInner :: (MonadTransControl t, Monad m, Monad (t m)) => (Run t -> m (StT t a)) -> t m a gmLiftWithInner f = liftWith f >>= restoreT . return ghc-mod-5.8.0.0/core/GhcMod/Monad/Orphans.hs0000644000000000000000000000571413112432356016472 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015,2016 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE CPP, UndecidableInstances, StandaloneDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module GhcMod.Monad.Orphans where #include "Compat.hs_h" import GhcMod.Types import GhcMod.Monad.Newtypes #if DIFFERENT_MONADIO import qualified MonadUtils as GHC (MonadIO(..)) #endif import qualified Control.Monad.IO.Class as MTL import Control.Monad.Reader (ReaderT(..)) import Control.Monad.State.Strict (StateT(..)) import Control.Monad.Trans.Journal (JournalT) import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Error (Error(..), ErrorT(..)) -------------------------------------------------- -- Miscellaneous instances #if DIFFERENT_MONADIO instance MTL.MonadIO m => GHC.MonadIO (ReaderT x m) where liftIO = MTL.liftIO instance MTL.MonadIO m => GHC.MonadIO (StateT x m) where liftIO = MTL.liftIO instance (Error e, MTL.MonadIO m) => GHC.MonadIO (ErrorT e m) where liftIO = MTL.liftIO instance MTL.MonadIO m => GHC.MonadIO (JournalT x m) where liftIO = MTL.liftIO instance MTL.MonadIO m => GHC.MonadIO (MaybeT m) where liftIO = MTL.liftIO deriving instance MTL.MonadIO m => GHC.MonadIO (GmOutT m) deriving instance MTL.MonadIO m => GHC.MonadIO (GmT m) deriving instance MTL.MonadIO m => GHC.MonadIO (GmlT m) deriving instance GHC.MonadIO LightGhc #endif deriving instance MTL.MonadIO m => MTL.MonadIO (GmOutT m) deriving instance MTL.MonadIO m => MTL.MonadIO (GmT m) deriving instance MTL.MonadIO m => MTL.MonadIO (GmlT m) deriving instance MTL.MonadIO LightGhc instance MonadIO IO where liftIO = id instance MonadIO m => MonadIO (ReaderT x m) where liftIO = MTL.liftIO instance MonadIO m => MonadIO (StateT x m) where liftIO = MTL.liftIO instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where liftIO = MTL.liftIO instance MonadIO m => MonadIO (JournalT x m) where liftIO = MTL.liftIO instance MonadIO m => MonadIO (MaybeT m) where liftIO = MTL.liftIO instance MonadIOC m => MonadIO (GmOutT m) where liftIO = MTL.liftIO instance MonadIOC m => MonadIO (GmT m) where liftIO = MTL.liftIO instance MonadIOC m => MonadIO (GmlT m) where liftIO = MTL.liftIO instance MonadIO LightGhc where liftIO = MTL.liftIO ghc-mod-5.8.0.0/core/GhcMod/Monad/Out.hs0000644000000000000000000000332313112432356015621 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015,2016 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-} module GhcMod.Monad.Out where import GhcMod.Types import GhcMod.Monad.Newtypes import Control.Monad import Control.Monad.State.Strict (StateT(..)) import Control.Monad.Trans.Journal (JournalT) import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Reader.Class import Control.Monad.Trans.Class (MonadTrans(..)) import Prelude class Monad m => GmOut m where gmoAsk :: m GhcModOut instance Monad m => GmOut (GmOutT m) where gmoAsk = GmOutT ask instance Monad m => GmOut (GmlT m) where gmoAsk = GmlT $ lift $ GmOutT ask instance GmOut m => GmOut (GmT m) where gmoAsk = lift gmoAsk instance GmOut m => GmOut (StateT s m) where gmoAsk = lift gmoAsk instance GmOut m => GmOut (JournalT w m) where gmoAsk = lift gmoAsk instance GmOut m => GmOut (MaybeT m) where gmoAsk = lift gmoAsk ghc-mod-5.8.0.0/core/GhcMod/Monad/State.hs0000644000000000000000000000422713112432356016136 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015,2016 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} {-# LANGUAGE FlexibleInstances, UndecidableInstances #-} module GhcMod.Monad.State where import GhcMod.Types import GhcMod.Monad.Newtypes import Control.Monad import Control.Monad.State.Strict (StateT(..)) import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.State.Class (MonadState(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import Prelude class Monad m => GmState m where gmsGet :: m GhcModState gmsGet = gmsState (\s -> (s, s)) gmsPut :: GhcModState -> m () gmsPut s = gmsState (\_ -> ((), s)) gmsState :: (GhcModState -> (a, GhcModState)) -> m a gmsState f = do s <- gmsGet let ~(a, s') = f s gmsPut s' return a {-# MINIMAL gmsState | gmsGet, gmsPut #-} instance GmState m => GmState (StateT s m) where gmsGet = lift gmsGet gmsPut = lift . gmsPut gmsState = lift . gmsState instance Monad m => GmState (StateT GhcModState m) where gmsGet = get gmsPut = put gmsState = state instance Monad m => GmState (GmT m) where gmsGet = GmT get gmsPut = GmT . put gmsState = GmT . state instance GmState m => GmState (MaybeT m) where gmsGet = MaybeT $ Just `liftM` gmsGet gmsPut = MaybeT . (Just `liftM`) . gmsPut gmsState = MaybeT . (Just `liftM`) . gmsState deriving instance (Monad m, GmState (GhcModT m)) => GmState (GmlT m) ghc-mod-5.8.0.0/core/GhcMod/Monad/Types.hs0000644000000000000000000001633213112432356016162 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-} {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-} {-# LANGUAGE TypeFamilies, UndecidableInstances, BangPatterns #-} {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module GhcMod.Monad.Types ( -- * Monad Types GhcModT , GmOutT(..) , GmT(..) , GmlT(..) , LightGhc(..) , GmGhc , IOish -- * Environment, state and logging , GhcModEnv(..) , GhcModState(..) , GhcModCaches(..) , defaultGhcModState , GmGhcSession(..) , GmComponent(..) -- * Accessing 'GhcModEnv', 'GhcModState' and 'GhcModLog' , GmLogLevel(..) , GhcModLog(..) , GhcModError(..) , Gm , GmEnv(..) , GmState(..) , GmLog(..) , GmOut(..) , cradle , options , outputOpts , withOptions , getMMappedFiles , setMMappedFiles , addMMappedFile , delMMappedFile , lookupMMappedFile , getMMappedFilePaths -- * Re-exporting convenient stuff , MonadIO , liftIO , gmlGetSession , gmlSetSession ) where #include "Compat.hs_h" import GhcMod.Types import GhcMod.Monad.Env import GhcMod.Monad.State import GhcMod.Monad.Log import GhcMod.Monad.Out import GhcMod.Monad.Newtypes import GhcMod.Monad.Orphans () import Safe import GHC import DynFlags import Exception import HscTypes import Control.Applicative import Control.Monad import Control.Monad.Reader (ReaderT(..)) import Control.Monad.State.Strict (StateT(..)) import Control.Monad.Trans.Journal (JournalT) import Control.Monad.Trans.Maybe (MaybeT) import Control.Monad.Trans.Control import Control.Monad.Reader.Class import qualified Data.Map as M import Data.Maybe import Data.Monoid import Data.IORef import Prelude type Gm m = (GmEnv m, GmState m, GmLog m, GmOut m) -------------------------------------------------- -- GHC API instances ----------------------------- -- GHC cannot prove the following instances to be decidable automatically using -- the FlexibleContexts extension as they violate the second Paterson Condition, -- namely that: The assertion has fewer constructors and variables (taken -- together and counting repetitions) than the head. Specifically the -- @MonadBaseControl IO m@ constraint in 'IOish' is causing this violation. type GmGhc m = (IOish m, GhcMonad m) instance (MonadIO m, MonadBaseControl IO m) => GhcMonad (GmlT m) where getSession = gmlGetSession setSession = gmlSetSession -- | Get the underlying GHC session gmlGetSession :: (MonadIO m, MonadBaseControl IO m) => GmlT m HscEnv gmlGetSession = do ref <- gmgsSession . fromJustNote "gmlGetSession" . gmGhcSession <$> gmsGet liftIO $ readIORef ref -- | Set the underlying GHC session gmlSetSession :: (MonadIO m, MonadBaseControl IO m) => HscEnv -> GmlT m () gmlSetSession a = do ref <- gmgsSession . fromJustNote "gmlSetSession" . gmGhcSession <$> gmsGet liftIO $ flip writeIORef a ref instance GhcMonad LightGhc where getSession = (liftIO . readIORef) =<< LightGhc ask setSession a = (liftIO . flip writeIORef a) =<< LightGhc ask #if __GLASGOW_HASKELL__ >= 706 instance (MonadIO m, MonadBaseControl IO m) => HasDynFlags (GmlT m) where getDynFlags = hsc_dflags <$> getSession instance HasDynFlags LightGhc where getDynFlags = hsc_dflags <$> getSession #endif instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmOutT m) where gcatch act handler = control $ \run -> run act `gcatch` (run . handler) gmask = liftBaseOp gmask . liftRestore where liftRestore f r = f $ liftBaseOp_ r instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmT m) where gcatch act handler = control $ \run -> run act `gcatch` (run . handler) gmask = liftBaseOp gmask . liftRestore where liftRestore f r = f $ liftBaseOp_ r instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmlT m) where gcatch act handler = control $ \run -> run act `gcatch` (run . handler) gmask = liftBaseOp gmask . liftRestore where liftRestore f r = f $ liftBaseOp_ r instance ExceptionMonad LightGhc where gcatch act handl = LightGhc $ unLightGhc act `gcatch` \e -> unLightGhc (handl e) gmask f = LightGhc $ gmask $ \io_restore ->let g_restore (LightGhc m) = LightGhc $ io_restore m in unLightGhc (f g_restore) instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (StateT s m) where gcatch act handler = control $ \run -> run act `gcatch` (run . handler) gmask = liftBaseOp gmask . liftRestore where liftRestore f r = f $ liftBaseOp_ r instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (ReaderT s m) where gcatch act handler = control $ \run -> run act `gcatch` (run . handler) gmask = liftBaseOp gmask . liftRestore where liftRestore f r = f $ liftBaseOp_ r instance (Monoid w, MonadIO m, MonadBaseControl IO m) => ExceptionMonad (JournalT w m) where gcatch act handler = control $ \run -> run act `gcatch` (run . handler) gmask = liftBaseOp gmask . liftRestore where liftRestore f r = f $ liftBaseOp_ r instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (MaybeT m) where gcatch act handler = control $ \run -> run act `gcatch` (run . handler) gmask = liftBaseOp gmask . liftRestore where liftRestore f r = f $ liftBaseOp_ r ---------------------------------------------------------------- options :: GmEnv m => m Options options = gmOptions `liftM` gmeAsk outputOpts :: GmOut m => m OutputOpts outputOpts = gmoOptions `liftM` gmoAsk cradle :: GmEnv m => m Cradle cradle = gmCradle `liftM` gmeAsk getMMappedFiles :: GmState m => m FileMappingMap getMMappedFiles = gmMMappedFiles `liftM` gmsGet setMMappedFiles :: GmState m => FileMappingMap -> m () setMMappedFiles mf = (\s -> gmsPut s { gmMMappedFiles = mf } ) =<< gmsGet addMMappedFile :: GmState m => FilePath -> FileMapping -> m () addMMappedFile t fm = getMMappedFiles >>= setMMappedFiles . M.insert t fm delMMappedFile :: GmState m => FilePath -> m () delMMappedFile t = getMMappedFiles >>= setMMappedFiles . M.delete t lookupMMappedFile :: GmState m => FilePath -> m (Maybe FileMapping) lookupMMappedFile t = M.lookup t `liftM` getMMappedFiles getMMappedFilePaths :: GmState m => m [FilePath] getMMappedFilePaths = M.keys `liftM` getMMappedFiles withOptions :: GmEnv m => (Options -> Options) -> m a -> m a withOptions changeOpt action = gmeLocal changeEnv action where changeEnv e = e { gmOptions = changeOpt opt } where opt = gmOptions e ghc-mod-5.8.0.0/core/GhcMod/Monad/Compat.hs_h0000644000000000000000000000241213112432356016602 0ustar0000000000000000-- ghc-mod: Making Haskell development *more* fun -- Copyright (C) 2015,2016 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -- MonadUtils of GHC 7.6 or earlier defines its own MonadIO. -- RWST does not automatically become an instance of MonadIO. -- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class. -- So, RWST automatically becomes an instance of #if __GLASGOW_HASKELL__ < 708 -- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different -- classes before ghc 7.8 #define DIFFERENT_MONADIO 1 -- RWST doen't have a MonadIO instance before ghc 7.8 #define MONADIO_INSTANCES 1 #endif ghc-mod-5.8.0.0/core/GhcMod/Options/0000755000000000000000000000000013112432356015112 5ustar0000000000000000ghc-mod-5.8.0.0/core/GhcMod/Options/DocUtils.hs0000644000000000000000000000231413112432356017174 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015 Nikolay Yakimov -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . module GhcMod.Options.DocUtils ( ($$), ($$$), (<=>), (<$$>), (<||>) ) where import Options.Applicative import Data.Monoid import Prelude infixl 6 <||> infixr 7 <$$> infixr 7 $$ infixr 8 <=> infixr 9 $$$ ($$) :: (a -> b) -> a -> b ($$) = ($) ($$$) :: (a -> b) -> a -> b ($$$) = ($) (<||>) :: Alternative a => a b -> a b -> a b (<||>) = (<|>) (<=>) :: Monoid m => m -> m -> m (<=>) = (<>) (<$$>) :: Functor f => (a -> b) -> f a -> f b (<$$>) = (<$>) ghc-mod-5.8.0.0/core/GhcMod/Options/Help.hs0000644000000000000000000000436513112432356016346 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015 Nikolay Yakimov -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE OverloadedStrings, FlexibleInstances, GeneralizedNewtypeDeriving #-} module GhcMod.Options.Help where import Options.Applicative import Options.Applicative.Help.Pretty (Doc) import qualified Options.Applicative.Help.Pretty as PP import Control.Monad.State import GHC.Exts( IsString(..) ) import Data.Maybe import Data.Monoid import Prelude newtype MyDocM s a = MyDoc {unwrapState :: State s a} deriving (Monad, Functor, Applicative, MonadState s) type MyDoc = MyDocM (Maybe Doc) () instance IsString (MyDocM (Maybe Doc) a) where fromString = append . para instance Monoid (MyDocM (Maybe Doc) ()) where mappend a b = append $ doc a <> doc b mempty = append PP.empty para :: String -> Doc para = PP.fillSep . map PP.text . words append :: Doc -> MyDocM (Maybe Doc) a append s = modify m >> return undefined where m :: Maybe Doc -> Maybe Doc m Nothing = Just s m (Just old) = Just $ old PP..$. s infixr 7 \\ (\\) :: MyDoc -> MyDoc -> MyDoc (\\) a b = append $ doc a PP.<+> doc b doc :: MyDoc -> Doc doc = fromMaybe PP.empty . flip execState Nothing . unwrapState help' :: MyDoc -> Mod f a help' = helpDoc . Just . doc desc :: MyDoc -> InfoMod a desc = footerDoc . Just . doc . indent 2 code :: MyDoc -> MyDoc code x = do _ <- " " indent 4 x " " progDesc' :: MyDoc -> InfoMod a progDesc' = progDescDoc . Just . doc indent :: Int -> MyDoc -> MyDoc indent n = append . PP.indent n . doc int' :: Int -> MyDoc int' = append . PP.int para' :: String -> MyDoc para' = append . para ghc-mod-5.8.0.0/core/GhcMod/Options/Options.hs0000644000000000000000000001403513112432356017104 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015 Nikolay Yakimov -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} module GhcMod.Options.Options ( globalArgSpec , parseCmdLineOptions ) where import Options.Applicative import Options.Applicative.Types import GhcMod.Types import Control.Arrow import Data.Char (toUpper, toLower) import Data.List (intercalate) import GhcMod.Read import GhcMod.Options.DocUtils import GhcMod.Options.Help import Data.Monoid import Prelude -- | Parse a set of arguments according to the ghc-mod CLI flag spec, producing -- @Options@ set accordingly. parseCmdLineOptions :: [String] -> Maybe Options parseCmdLineOptions = getParseResult . execParserPure (prefs mempty) (info globalArgSpec mempty) splitOn :: Eq a => a -> [a] -> ([a], [a]) splitOn c = second (drop 1) . break (==c) logLevelParser :: Parser GmLogLevel logLevelParser = logLevelSwitch <*> logLevelOption <||> silentSwitch where logLevelOption = option parseLL $$ long "verbose" <=> metavar "LEVEL" <=> value GmWarning <=> showDefaultWith showLL <=> help' $$$ do "Set log level (" <> int' (fromEnum (minBound :: GmLogLevel)) <> "-" <> int' (fromEnum (maxBound :: GmLogLevel)) <> ")" "You can also use strings (case-insensitive):" para' $ intercalate ", " $ map showLL ([minBound..maxBound] :: [GmLogLevel]) logLevelSwitch = repeatAp succ' . length <$> many $$ flag' () $$ short 'v' <=> help "Increase log level" silentSwitch = flag' GmSilent $$ long "silent" <=> short 's' <=> help "Be silent, set log level to 'silent'" showLL = drop 2 . map toLower . show repeatAp f n = foldr (.) id (replicate n f) succ' x | x == maxBound = x | otherwise = succ x parseLL = do v <- readerAsk let il'= toEnum . min maxBound <$> readMaybe v ll' = readMaybe ("Gm" ++ capFirst v) maybe (readerError $ "Not a log level \"" ++ v ++ "\"") return $ ll' <|> il' capFirst (h:t) = toUpper h : map toLower t capFirst [] = [] outputOptsSpec :: Parser OutputOpts outputOptsSpec = OutputOpts <$> logLevelParser <*> flag PlainStyle LispStyle $$ long "tolisp" <=> short 'l' <=> help "Format output as an S-Expression" <*> LineSeparator <$$> strOption $$ long "boundary" <=> long "line-separator" <=> short 'b' <=> metavar "SEP" <=> value "\0" <=> showDefault <=> help "Output line separator" <*> optional $$ splitOn ',' <$$> strOption $$ long "line-prefix" <=> metavar "OUT,ERR" <=> help "Output prefixes" programsArgSpec :: Parser Programs programsArgSpec = Programs <$> strOption $$ long "with-ghc" <=> value "ghc" <=> showDefault <=> help "GHC executable to use" <*> strOption $$ long "with-ghc-pkg" <=> value "ghc-pkg" <=> showDefault <=> help "ghc-pkg executable to use (only needed when guessing from GHC path fails)" <*> strOption $$ long "with-cabal" <=> value "cabal" <=> showDefault <=> help "cabal-install executable to use" <*> strOption $$ long "with-stack" <=> value "stack" <=> showDefault <=> help "stack executable to use" -- | An optparse-applicative @Parser@ sepcification for @Options@ so that -- applications making use of the ghc-mod API can have a consistent way of -- parsing global options. globalArgSpec :: Parser Options globalArgSpec = Options <$> outputOptsSpec <*> programsArgSpec <*> many $$ strOption $$ long "ghcOpt" <=> long "ghc-option" <=> short 'g' <=> metavar "OPT" <=> help "Option to be passed to GHC" <*> many fileMappingSpec <*> strOption $$ long "encoding" <=> value "UTF-8" <=> showDefault <=> help "I/O encoding" <*> switch $$ long "stack-build-deps" <=> showDefault <=> help "Build dependencies if needed when using stack" where fileMappingSpec = getFileMapping . splitOn '=' <$> strOption $$ long "map-file" <=> metavar "MAPPING" <=> fileMappingHelp fileMappingHelp = help' $ do "Redirect one file to another" "--map-file \"file1.hs=file2.hs\"" indent 4 $ do "can be used to tell ghc-mod" \\ "that it should take source code" \\ "for `file1.hs` from `file2.hs`." "`file1.hs` can be either full path," \\ "or path relative to project root." "`file2.hs` has to be either relative to project root," \\ "or full path (preferred)" "--map-file \"file.hs\"" indent 4 $ do "can be used to tell ghc-mod that it should take" \\ "source code for `file.hs` from stdin. File end" \\ "marker is `\\n\\EOT\\n`, i.e. `\\x0A\\x04\\x0A`." \\ "`file.hs` may or may not exist, and should be" \\ "either full path, or relative to project root." getFileMapping = second (\i -> if null i then Nothing else Just i) ghc-mod-5.8.0.0/core/Data/0000755000000000000000000000000013112432356013167 5ustar0000000000000000ghc-mod-5.8.0.0/core/Data/Binary/0000755000000000000000000000000013112432356014413 5ustar0000000000000000ghc-mod-5.8.0.0/core/Data/Binary/Generic.hs0000644000000000000000000001066513112432356016333 0ustar0000000000000000{-# LANGUAGE BangPatterns, CPP, FlexibleInstances, KindSignatures, ScopedTypeVariables, TypeOperators, TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Binary.Generic -- Copyright : Bryan O'Sullivan -- License : BSD3-style (see LICENSE) -- -- Maintainer : Bryan O'Sullivan -- Stability : unstable -- Portability : Only works with GHC 7.2 and newer -- -- Instances for supporting GHC generics. -- ----------------------------------------------------------------------------- module Data.Binary.Generic where import Control.Applicative import Data.Binary import Data.Bits import GHC.Generics import Prelude class GGBinary f where ggput :: f t -> Put ggget :: Get (f t) -- Type without constructors instance GGBinary V1 where ggput _ = return () ggget = return undefined -- Constructor without arguments instance GGBinary U1 where ggput U1 = return () ggget = return U1 -- Product: constructor with parameters instance (GGBinary a, GGBinary b) => GGBinary (a :*: b) where ggput (x :*: y) = ggput x >> ggput y ggget = (:*:) <$> ggget <*> ggget -- Metadata (constructor name, etc) instance GGBinary a => GGBinary (M1 i c a) where ggput = ggput . unM1 ggget = M1 <$> ggget -- Constants, additional parameters, and rank-1 recursion instance Binary a => GGBinary (K1 i a) where ggput = put . unK1 ggget = K1 <$> get -- Borrowed from the cereal package. -- The following GGBinary instance for sums has support for serializing -- types with up to 2^64-1 constructors. It will use the minimal -- number of bytes needed to encode the constructor. For example when -- a type has 2^8 constructors or less it will use a single byte to -- encode the constructor. If it has 2^16 constructors or less it will -- use two bytes, and so on till 2^64-1. #define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD) #define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size) #define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size) instance ( GSum a, GSum b , SumSize a, SumSize b) => GGBinary (a :+: b) where ggput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64) | otherwise = sizeError "encode" size where size = unTagged (sumSize :: Tagged (a :+: b) Word64) {-# INLINE ggput #-} ggget | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) | GETSUM(Word64) | otherwise = sizeError "decode" size where size = unTagged (sumSize :: Tagged (a :+: b) Word64) {-# INLINE ggget #-} sizeError :: Show size => String -> size -> error sizeError s size = error $ "Can't " ++ s ++ " a type with " ++ show size ++ " constructors" ------------------------------------------------------------------------ checkGetSum :: (Ord word, Num word, Bits word, GSum f) => word -> word -> Get (f a) checkGetSum size code | code < size = getSum code size | otherwise = fail "Unknown encoding for constructor" {-# INLINE checkGetSum #-} class GSum f where getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a) putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put instance (GSum a, GSum b) => GSum (a :+: b) where getSum !code !size | code < sizeL = L1 <$> getSum code sizeL | otherwise = R1 <$> getSum (code - sizeL) sizeR where sizeL = size `shiftR` 1 sizeR = size - sizeL {-# INLINE getSum #-} putSum !code !size s = case s of L1 x -> putSum code sizeL x R1 x -> putSum (code + sizeL) sizeR x where sizeL = size `shiftR` 1 sizeR = size - sizeL {-# INLINE putSum #-} instance GGBinary a => GSum (C1 c a) where getSum _ _ = ggget {-# INLINE getSum #-} putSum !code _ x = put code *> ggput x {-# INLINE putSum #-} ------------------------------------------------------------------------ class SumSize f where sumSize :: Tagged f Word64 newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b} instance (SumSize a, SumSize b) => SumSize (a :+: b) where sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) + unTagged (sumSize :: Tagged b Word64) instance SumSize (C1 c a) where sumSize = Tagged 1 ghc-mod-5.8.0.0/shared/0000755000000000000000000000000013112432356012634 5ustar0000000000000000ghc-mod-5.8.0.0/shared/Utils.hs0000644000000000000000000000125113112432356014267 0ustar0000000000000000{-# 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 ghc-mod-5.8.0.0/shared/System/0000755000000000000000000000000013112432356014120 5ustar0000000000000000ghc-mod-5.8.0.0/shared/System/Directory/0000755000000000000000000000000013112432356016064 5ustar0000000000000000ghc-mod-5.8.0.0/shared/System/Directory/ModTime.hs0000644000000000000000000000371713112432356017766 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} module System.Directory.ModTime where import Control.Applicative import Control.DeepSeq import Data.Binary #if MIN_VERSION_directory(1,2,0) import Data.Time (UTCTime(..), Day(..), getCurrentTime) #else import System.Time (ClockTime(..), getClockTime) #endif import System.Directory import Prelude #if MIN_VERSION_directory(1,2,0) newtype ModTime = ModTime UTCTime deriving (Eq, Ord, NFData) getCurrentModTime = ModTime <$> getCurrentTime instance Binary ModTime where put (ModTime (UTCTime (ModifiedJulianDay day) difftime)) = put day >> put (toRational difftime) get = ModTime <$> (UTCTime <$> (ModifiedJulianDay <$> get) <*> (fromRational <$> get)) #else newtype ModTime = ModTime ClockTime deriving (Eq, Ord) getCurrentModTime = ModTime <$> getClockTime instance Binary ModTime where put (ModTime (TOD s ps)) = put s >> put ps get = ModTime <$> (TOD <$> get <*> get) instance NFData ModTime where rnf (ModTime (TOD s ps)) = s `seq` ps `seq` (ModTime $! TOD s ps) `seq` () #endif getCurrentModTime :: IO ModTime getModTime :: FilePath -> IO ModTime getModTime f = ModTime <$> getModificationTime f ghc-mod-5.8.0.0/src/0000755000000000000000000000000013112432356012155 5ustar0000000000000000ghc-mod-5.8.0.0/src/GhcModi.hs0000644000000000000000000000302213112432356014020 0ustar0000000000000000{-# 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 ghc-mod-5.8.0.0/src/GhcModMain.hs0000644000000000000000000001416113112432356014462 0ustar0000000000000000{-# 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 ghc-mod-5.8.0.0/src/GhcMod/0000755000000000000000000000000013112432356013316 5ustar0000000000000000ghc-mod-5.8.0.0/src/GhcMod/Exe/0000755000000000000000000000000013112432356014037 5ustar0000000000000000ghc-mod-5.8.0.0/src/GhcMod/Exe/Options.hs0000644000000000000000000000437213112432356016034 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015 Nikolay Yakimov -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} module GhcMod.Exe.Options ( parseArgs, parseArgsInteractive, GhcModCommands(..) ) where import Options.Applicative import Options.Applicative.Types import GhcMod.Exe.Options.Commands import GhcMod.Exe.Options.ShellParse import GhcMod.Exe.Version import GhcMod.Options.DocUtils import GhcMod.Options.Options import GhcMod.Types parseArgs :: IO (Options, GhcModCommands) parseArgs = execParser opts where opts = info (argAndCmdSpec <**> helpVersion) $$ fullDesc <=> header "ghc-mod: Happy Haskell Hacking" parseArgsInteractive :: String -> Either String GhcModCommands parseArgsInteractive args = handle $ execParserPure (prefs idm) opts $ parseCmdLine args where opts = info interactiveCommandsSpec $$ fullDesc handle (Success a) = Right a handle (Failure failure) = Left $ fst $ renderFailure failure "" handle _ = Left "Completion invoked" helpVersion :: Parser (a -> a) helpVersion = helper <*> abortOption (InfoMsg ghcModVersion) $$ long "version" <=> help "Print the version of the program." <*> argument r $$ value id <=> metavar "" where r :: ReadM (a -> a) r = do v <- readerAsk case v of "help" -> readerAbort ShowHelpText "version" -> readerAbort $ InfoMsg ghcModVersion _ -> return id argAndCmdSpec :: Parser (Options, GhcModCommands) argAndCmdSpec = (,) <$> globalArgSpec <*> commandsSpec ghc-mod-5.8.0.0/src/GhcMod/Exe/Version.hs0000644000000000000000000000222713112432356016023 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015 Nikolay Yakimov -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . module GhcMod.Exe.Version where import Paths_ghc_mod import Data.Version (showVersion) import Config (cProjectVersion) progVersion :: String -> String progVersion pf = "ghc-mod"++pf++" version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ghcModVersion :: String ghcModVersion = progVersion "" ghcModiVersion :: String ghcModiVersion = progVersion "i" ghc-mod-5.8.0.0/src/GhcMod/Exe/Options/0000755000000000000000000000000013112432356015472 5ustar0000000000000000ghc-mod-5.8.0.0/src/GhcMod/Exe/Options/Commands.hs0000644000000000000000000002471013112432356017573 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015 Nikolay Yakimov -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} module GhcMod.Exe.Options.Commands where import Data.Semigroup import Options.Applicative import Options.Applicative.Types import Options.Applicative.Builder.Internal import GhcMod.Types import GhcMod.Read import GhcMod.Options.DocUtils import GhcMod.Options.Help type Symbol = String type Expr = String type Module = String type Line = Int type Col = Int type Point = (Line, Col) data GhcModCommands = CmdLang | CmdFlag | CmdDebug | CmdBoot | CmdNukeCaches | CmdRoot | CmdLegacyInteractive | CmdModules Bool | CmdDumpSym | CmdFind Symbol | CmdDoc Module | CmdLint LintOpts FilePath | CmdBrowse BrowseOpts [Module] | CmdDebugComponent [String] | CmdCheck [FilePath] | CmdExpand [FilePath] | CmdInfo FilePath Symbol | CmdType Bool FilePath Point | CmdSplit FilePath Point | CmdSig FilePath Point | CmdAuto FilePath Point | CmdRefine FilePath Point Expr | CmdTest FilePath -- interactive-only commands | CmdMapFile FilePath | CmdUnmapFile FilePath | CmdQuit deriving (Show) commandsSpec :: Parser GhcModCommands commandsSpec = hsubparser commands commands :: Mod CommandFields GhcModCommands commands = command "lang" $$ info (pure CmdLang) $$ progDesc "List all known GHC language extensions" <> command "flag" $$ info (pure CmdFlag) $$ progDesc "List GHC -f flags" <> command "debug" $$ info (pure CmdDebug) $$ progDesc' $$$ do "Print debugging information. Please include" \\ "the output in any bug reports you submit" <> command "debug-component" $$ info debugComponentArgSpec $$ progDesc' $$$ do "Debugging information related to cabal component" \\ "resolution" <> command "boot" $$ info (pure CmdBoot) $$ progDesc "Internal command used by the emacs frontend" -- <> command "nuke-caches" -- $$ info (pure CmdNukeCaches) idm <> command "root" $$ info (pure CmdRoot) $$ progDesc' "Try to find the project directory." <=> desc $$$ do "For Cabal projects this is the" \\ "directory containing the cabal file, for projects" \\ "that use a cabal sandbox but have no cabal file" \\ "this is the directory containing the cabal.sandbox.config" \\ "file and otherwise this is the current directory" <> command "legacy-interactive" $$ info legacyInteractiveArgSpec $$ progDesc "ghc-modi compatibility mode" <> command "list" $$ info modulesArgSpec $$ progDesc "List all visible modules" <> command "modules" $$ info modulesArgSpec $$ progDesc "List all visible modules" <> command "dumpsym" $$ info (pure CmdDumpSym) idm <> command "find" $$ info findArgSpec $$ progDesc "List all modules that define SYMBOL" <> command "doc" $$ info docArgSpec $$ progDesc' $$$ do "Try finding the html documentation directory" \\ "for the given MODULE" <> command "lint" $$ info lintArgSpec $$ progDesc "Check files using `hlint'" <> command "browse" $$ info browseArgSpec $$ progDesc "List symbols in a module" <> command "check" $$ info checkArgSpec $$ progDesc' $$$ do "Load the given files using GHC and report errors/warnings," \\ "but don't produce output files" <> command "expand" $$ info expandArgSpec $$ progDesc "Like `check' but also pass `-ddump-splices' to GHC" <> command "info" $$ info infoArgSpec $$ progDesc' $$$ do "Look up an identifier in the context" \\ "of FILE (like ghci's `:info')" <> command "type" $$ info typeArgSpec $$ progDesc "Get the type of the expression under (LINE,COL)" <> command "split" $$ info splitArgSpec $$ progDesc "Split a function case by examining a type's constructors" <=> desc $$$ do "For example given the following code snippet:" code $ do "f :: [a] -> a" "f x = _body" "would be replaced by:" code $ do "f :: [a] -> a" "f [] = _body" "f (x:xs) = _body" "(See https://github.com/DanielG/ghc-mod/pull/274)" <> command "sig" $$ info sigArgSpec $$ progDesc "Generate initial code given a signature" <=> desc $$$ do "For example when (LINE,COL) is on the" \\ "signature in the following code snippet:" code "func :: [a] -> Maybe b -> (a -> b) -> (a,b)" "ghc-mod would add the following on the next line:" code "func x y z f = _func_body" "(See: https://github.com/DanielG/ghc-mod/pull/274)" <> command "auto" $$ info autoArgSpec $$ progDesc "Try to automatically fill the contents of a hole" <> command "refine" $$ info refineArgSpec $$ progDesc "Refine the typed hole at (LINE,COL) given EXPR" <=> desc $$$ do "For example if EXPR is `filter', which has type" \\ "`(a -> Bool) -> [a] -> [a]' and (LINE,COL) is on" \\ " the hole `_body' in the following code snippet:" code $ do "filterNothing :: [Maybe a] -> [a]" "filterNothing xs = _body" "ghc-mod changes the code to get a value of type" \\ " `[a]', which results in:" code "filterNothing xs = filter _body_1 _body_2" "(See also: https://github.com/DanielG/ghc-mod/issues/311)" <> command "test" $$ info (CmdTest <$> strArg "FILE") $$ progDesc "" interactiveCommandsSpec :: Parser GhcModCommands interactiveCommandsSpec = hsubparser' $ commands <> command "map-file" $$ info mapArgSpec $$ progDesc "tells ghc-modi to read `file.hs` source from stdin" <=> desc $$$ do "Works the same as second form of" \\ "`--map-file` CLI option." <> command "unmap-file" $$ info unmapArgSpec $$ progDesc' $$$ do "unloads previously mapped file," \\ "so that it's no longer mapped." <=> desc $$$ do "`file.hs` can be full path or relative" \\ "to project root, either will work." <> command "quit" $$ info (pure CmdQuit) $$ progDesc "Exit interactive mode" <> command "" $$ info (pure CmdQuit) idm strArg :: String -> Parser String strArg = argument str . metavar filesArgsSpec :: Parser ([String] -> b) -> Parser b filesArgsSpec x = x <*> some (strArg "FILES..") locArgSpec :: Parser (String -> (Int, Int) -> b) -> Parser b locArgSpec x = x <*> strArg "FILE" <*> ( (,) <$> argument int (metavar "LINE") <*> argument int (metavar "COL") ) modulesArgSpec, docArgSpec, findArgSpec, lintArgSpec, browseArgSpec, checkArgSpec, expandArgSpec, infoArgSpec, typeArgSpec, autoArgSpec, splitArgSpec, sigArgSpec, refineArgSpec, debugComponentArgSpec, mapArgSpec, unmapArgSpec, legacyInteractiveArgSpec :: Parser GhcModCommands modulesArgSpec = CmdModules <$> switch $$ long "detailed" <=> short 'd' <=> help "Print package modules belong to" findArgSpec = CmdFind <$> strArg "SYMBOL" docArgSpec = CmdDoc <$> strArg "MODULE" lintArgSpec = CmdLint <$> LintOpts <$$> many $$ strOption $$ long "hlintOpt" <=> short 'h' <=> help "Option to be passed to hlint" <*> strArg "FILE" browseArgSpec = CmdBrowse <$> (BrowseOpts <$> switch $$ long "operators" <=> short 'o' <=> help "Also print operators" <*> switch $$ long "detailed" <=> short 'd' <=> help "Print symbols with accompanying signature" <*> switch $$ long "parents" <=> short 'p' <=> help "Print symbols parents" <*> switch $$ long "qualified" <=> short 'q' <=> help "Qualify symbols" ) <*> some (strArg "MODULE") debugComponentArgSpec = filesArgsSpec (pure CmdDebugComponent) checkArgSpec = filesArgsSpec (pure CmdCheck) expandArgSpec = filesArgsSpec (pure CmdExpand) infoArgSpec = CmdInfo <$> strArg "FILE" <*> strArg "SYMBOL" typeArgSpec = locArgSpec $ CmdType <$> switch $$ long "constraints" <=> short 'c' <=> help "Include constraints into type signature" autoArgSpec = locArgSpec (pure CmdAuto) splitArgSpec = locArgSpec (pure CmdSplit) sigArgSpec = locArgSpec (pure CmdSig) refineArgSpec = locArgSpec (pure CmdRefine) <*> strArg "SYMBOL" mapArgSpec = CmdMapFile <$> strArg "FILE" unmapArgSpec = CmdUnmapFile <$> strArg "FILE" legacyInteractiveArgSpec = const CmdLegacyInteractive <$> optional interactiveCommandsSpec hsubparser' :: Mod CommandFields a -> Parser a hsubparser' m = mkParser d g rdr where Mod _ d g = m `mappend` metavar "" (ms, cmds, subs) = mkCommand m rdr = CmdReader ms cmds (fmap add_helper . subs) add_helper pinfo = pinfo { infoParser = infoParser pinfo <**> helper } int :: ReadM Int int = do v <- readerAsk maybe (readerError $ "Not a number \"" ++ v ++ "\"") return $ readMaybe v ghc-mod-5.8.0.0/src/GhcMod/Exe/Options/ShellParse.hs0000644000000000000000000000317213112432356020073 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015 Nikolay Yakimov -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . module GhcMod.Exe.Options.ShellParse (parseCmdLine) where import Data.Char import Data.List go :: String -> String -> [String] -> Bool -> [String] -- result go [] curarg accargs _ = reverse $ reverse curarg : accargs go (c:cl) curarg accargs quotes -- open quotes | c == '\STX', not quotes = go cl curarg accargs True -- close quotes | c == '\ETX', quotes = go cl curarg accargs False -- space separates arguments outside quotes | isSpace c, not quotes = if null curarg then go cl curarg accargs quotes else go cl [] (reverse curarg : accargs) quotes -- general character | otherwise = go cl (c:curarg) accargs quotes parseCmdLine :: String -> [String] parseCmdLine comline' | Just comline <- stripPrefix "ascii-escape " $ dropWhile isSpace comline' = go (dropWhile isSpace comline) [] [] False parseCmdLine [] = [""] parseCmdLine comline = words comline ghc-mod-5.8.0.0/shelltest/0000755000000000000000000000000013112432356013375 5ustar0000000000000000ghc-mod-5.8.0.0/shelltest/ShellTest.hs0000644000000000000000000000164313112432356015644 0ustar0000000000000000#!/usr/bin/env runhaskell -- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2017 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . module Main where import System.Exit import System.Process main = exitWith =<< rawSystem "shelltest" [ "--execdir", "shelltest/" ] ghc-mod-5.8.0.0/test/0000755000000000000000000000000013112432356012345 5ustar0000000000000000ghc-mod-5.8.0.0/test/Main.hs0000644000000000000000000000644013112432356013571 0ustar0000000000000000{-# LANGUAGE CPP, ScopedTypeVariables #-} import Dir import Control.Exception as E import Control.Monad (void) 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 #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 ("rm cabal.sandbox.config; cabal sandbox init") pkgDirs = [ "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 let cleanCmd = "git clean -dXf test/data/" putStrLn $ "$ " ++ cleanCmd void $ system cleanCmd void $ system "cabal --version" 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 () ) hspec spec ghc-mod-5.8.0.0/test/Dir.hs0000644000000000000000000000162413112432356013422 0ustar0000000000000000module Dir ( module Dir , getCurrentDirectory , () ) where import Control.Exception as E import Data.List (isPrefixOf) import System.Directory import System.FilePath (addTrailingPathSeparator,()) withDirectory_ :: FilePath -> IO a -> IO a withDirectory_ dir action = bracket getCurrentDirectory setCurrentDirectory (\_ -> setCurrentDirectory dir >> action) withDirectory :: FilePath -> (FilePath -> IO a) -> IO a withDirectory dir action = bracket getCurrentDirectory setCurrentDirectory (\d -> setCurrentDirectory dir >> action d) toRelativeDir :: FilePath -> FilePath -> FilePath toRelativeDir dir file | dir' `isPrefixOf` file = drop len file | otherwise = file where dir' = addTrailingPathSeparator dir len = length dir' ghc-mod-5.8.0.0/test/TestUtils.hs0000644000000000000000000000641113112432356014643 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} module TestUtils ( run , runD , runD' , runE , runNullLog , runGmOutDef , runLogDef , shouldReturnError , isPkgDbAt , isPkgConfDAt , module GhcMod.Monad , module GhcMod.Types ) where 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 ((.)) import Exception testLogLevel :: GmLogLevel testLogLevel = GmDebug extract :: Show e => IO (Either e a, w) -> IO a extract action = do (r,_) <- action case r of Right a -> return a Left e -> error $ show e runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog) runGhcModTSpec opt action = do dir <- getCurrentDirectory runGhcModTSpec' dir opt action runGhcModTSpec' :: IOish m => FilePath -> Options -> GhcModT m b -> m (Either GhcModError b, GhcModLog) runGhcModTSpec' dir opt action = liftIO (canonicalizePath dir) >>= \dir' -> 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 run :: Options -> GhcModT IO a -> IO a run opt a = extract $ runGhcModTSpec opt a -- | Run GhcMod with default options runD :: GhcModT IO a -> IO a runD = extract . runGhcModTSpec (setLogLevel testLogLevel 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 shouldReturnError action = do (a,_) <- action a `shouldSatisfy` isLeft 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 ghc-mod-5.8.0.0/test/BrowseSpec.hs0000644000000000000000000000246613112432356014765 0ustar0000000000000000module BrowseSpec where import Control.Applicative import GhcMod import Test.Hspec import Prelude import TestUtils import Dir spec :: Spec spec = do describe "browse Data.Map" $ do it "contains at least `differenceWithKey'" $ do 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 <- 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 <- runD $ lines <$> browse defaultBrowseOpts{ optBrowseDetailed = True } "Data.Either" syms `shouldContain` ["Left :: a -> Either a b"] describe "`browse' in a project directory" $ do 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"] ghc-mod-5.8.0.0/test/CabalHelperSpec.hs0000644000000000000000000000655013112432356015664 0ustar0000000000000000{-# 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 ghc-mod-5.8.0.0/test/CaseSplitSpec.hs0000644000000000000000000000645413112432356015414 0ustar0000000000000000{-# 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 ghc-mod-5.8.0.0/test/CheckSpec.hs0000644000000000000000000000763113112432356014540 0ustar0000000000000000{-# LANGUAGE CPP #-} module CheckSpec where import GhcMod import Data.List import System.Process import Test.Hspec import TestUtils import Dir spec :: Spec spec = do 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 <- 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 _ <- 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/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/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 <- runD $ checkSyntax ["B.hs"] res `shouldSatisfy` ("B.hs:6:9:Warning:" `isPrefixOf`) #endif it "works with foreign exports" $ do 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/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 ghc-mod-5.8.0.0/test/CradleSpec.hs0000644000000000000000000000463413112432356014715 0ustar0000000000000000module 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") ghc-mod-5.8.0.0/test/CustomPackageDbSpec.hs0000644000000000000000000000215113112432356016507 0ustar0000000000000000module 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 ghc-mod-5.8.0.0/test/FileMappingSpec.hs0000644000000000000000000003343713112432356015721 0ustar0000000000000000module 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"] } ghc-mod-5.8.0.0/test/FindSpec.hs0000644000000000000000000000055713112432356014403 0ustar0000000000000000{-# 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"] ghc-mod-5.8.0.0/test/FlagSpec.hs0000644000000000000000000000050513112432356014365 0ustar0000000000000000module FlagSpec where import Control.Applicative import GhcMod import Test.Hspec import TestUtils import Prelude spec :: Spec spec = do describe "flags" $ do it "contains at least `-fprint-explicit-foralls" $ do f <- runD $ lines <$> flags f `shouldContain` ["-fprint-explicit-foralls"] ghc-mod-5.8.0.0/test/GhcPkgSpec.hs0000644000000000000000000000122413112432356014656 0ustar0000000000000000module GhcPkgSpec where 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 "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 ghc-mod-5.8.0.0/test/HomeModuleGraphSpec.hs0000644000000000000000000001412013112432356016532 0ustar0000000000000000-- ghc-mod: Happy Haskell Hacking -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE OverloadedStrings #-} module HomeModuleGraphSpec where import GhcMod.HomeModuleGraph import GhcMod.LightGhc import TestUtils import GHC import qualified Data.Map as Map import qualified Data.Set as Set import Data.Maybe import Test.Hspec runAGhc :: [GHCOption] -> (HscEnv -> LightGhc a) -> IO a runAGhc opts action = withLightHscEnv opts $ \env -> do runLightGhc env $ getSession >>= action hmGraph :: FilePath -> [String] -> String -> IO GmModuleGraph hmGraph dir opts mn = runAGhc opts $ \env -> liftIO $ do runD' dir $ do smp <- liftIO $ findModulePathSet env [mkModuleName mn] homeModuleGraph env smp uhmGraph :: FilePath -> [String] -> String -> String -> GmModuleGraph -> IO GmModuleGraph uhmGraph dir opts mn umn g = runAGhc opts $ \env -> liftIO $ do runD' dir $ do smp <- liftIO $ findModulePathSet env [mkModuleName mn] usmp <- liftIO $ findModulePathSet env [mkModuleName umn] updateHomeModuleGraph env g smp usmp mapMap :: (Ord k, Ord k') => (k -> k') -> (a -> a') -> Map.Map k a -> Map.Map k' a' mapMap fk fa = Map.mapKeys fk . Map.map fa mapMpFn :: (FilePath -> FilePath) -> ModulePath -> ModulePath mapMpFn f (ModulePath mn fn) = ModulePath mn (f fn) mp :: ModuleName -> ModulePath mp mn = ModulePath mn $ moduleNameString mn ++ ".hs" spec :: Spec spec = do describe "reachable" $ do let smp = Set.fromList [ mp "A" , mp "B" , mp "C" , mp "D" , mp "E" , mp "F" , mp "G" , mp "H" , mp "I" ] moduleMap = mkModuleMap smp completeGraph = Map.map (Set.map lookupMM) . Map.mapKeys lookupMM lookupMM = fromJust . flip Map.lookup moduleMap graph = completeGraph $ Map.fromList [ ("A", Set.fromList ["B"]) , ("B", Set.fromList ["C", "D"]) , ("C", Set.fromList ["F"]) , ("D", Set.fromList ["E"]) , ("E", Set.fromList []) , ("F", Set.fromList []) , ("G", Set.fromList []) , ("H", Set.fromList []) , ("I", Set.fromList []) ] really_reachable = Set.fromList [ mp "A" , mp "B" , mp "C" , mp "D" , mp "E" , mp "F" ] g = GmModuleGraph { gmgGraph = graph } it "reachable Set.empty g == Set.empty" $ do reachable Set.empty g `shouldBe` Set.empty it "lists only reachable nodes" $ do reachable (Set.fromList [mp "A"]) g `shouldBe` really_reachable describe "homeModuleGraph" $ do it "cycles don't break it" $ do let tdir = "test/data/home-module-graph/cycle" g <- hmGraph tdir [] "A" gmgGraph g `shouldBe` Map.fromList [ (mp "A", Set.fromList [mp "B"]) , (mp "B", Set.fromList [mp "A"]) ] it "follows imports" $ do let tdir = "test/data/home-module-graph/indirect" g <- hmGraph tdir [] "A" gmgGraph g `shouldBe` Map.fromList [ (mp "A", Set.fromList [mp "A1", mp "A2", mp "A3"]) , (mp "A1", Set.fromList [mp "B"]) , (mp "A2", Set.fromList [mp "C"]) , (mp "A3", Set.fromList [mp "B"]) , (mp "B", Set.fromList []) , (mp "C", Set.fromList []) ] it "returns partial results on parse errors" $ do let tdir = "test/data/home-module-graph/errors" g <- hmGraph tdir [] "A" gmgGraph g `shouldBe` Map.fromList [ (mp "A", Set.fromList [mp "A1", mp "A2", mp "A3"]) , (mp "A1", Set.fromList []) -- parse error here , (mp "A2", Set.fromList []) , (mp "A3", Set.fromList [mp "B"]) , (mp "B", Set.fromList []) ] it "returns partial results on CPP errors" $ do let tdir = "test/data/home-module-graph/cpp" g <- hmGraph tdir [] "A" gmgGraph g `shouldBe` Map.fromList [ (mp "A", Set.fromList [mp "A1", mp "A2", mp "A3"]) , (mp "A1", Set.fromList []) -- CPP error here , (mp "A2", Set.fromList []) , (mp "A3", Set.fromList [mp "B"]) , (mp "B", Set.fromList []) ] describe "updateHomeModuleGraph" $ do it "removes unreachable nodes" $ do let tdir = "test/data/home-module-graph/indirect" let tdir' = "test/data/home-module-graph/indirect-update" ig <- hmGraph tdir [] "A" g <- uhmGraph tdir' [] "A" "A2" ig gmgGraph g `shouldBe` Map.fromList [ (mp "A", Set.fromList [mp "A1", mp "A2", mp "A3"]) , (mp "A1", Set.fromList [mp "B"]) , (mp "A2", Set.fromList []) , (mp "A3", Set.fromList [mp "B"]) , (mp "B", Set.fromList []) -- C was removed ] ghc-mod-5.8.0.0/test/InfoSpec.hs0000644000000000000000000000515013112432356014410 0ustar0000000000000000{-# LANGUAGE CPP #-} module InfoSpec where import Control.Applicative import Data.List (isPrefixOf) import GhcMod #if __GLASGOW_HASKELL__ < 706 import System.Environment.Executable (getExecutablePath) #else import System.Environment (getExecutablePath) #endif import System.FilePath import Test.Hspec import TestUtils import Prelude spec :: Spec spec = do describe "types" $ do it "shows types of the expression and its outers" $ do 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 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 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 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 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 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 ghc-mod-5.8.0.0/test/LangSpec.hs0000644000000000000000000000050513112432356014375 0ustar0000000000000000module LangSpec where import Control.Applicative import GhcMod import Test.Hspec import TestUtils import Prelude spec :: Spec spec = do describe "languages" $ do it "contains at lest `OverloadedStrings'" $ do exts <- runD $ lines <$> languages exts `shouldContain` ["OverloadedStrings"] ghc-mod-5.8.0.0/test/LintSpec.hs0000644000000000000000000000135113112432356014422 0ustar0000000000000000module LintSpec where import GhcMod import Test.Hspec import TestUtils spec :: Spec spec = do describe "lint" $ do it "can detect a redundant import" $ do 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 lintOpts "test/data/ghc-mod-check/lib/Data/Foo.hs" res `shouldBe` "" lintOpts :: LintOpts lintOpts = defaultLintOpts { optLintHlintOpts = ["--ignore=Use module export list"] } ghc-mod-5.8.0.0/test/ListSpec.hs0000644000000000000000000000046613112432356014435 0ustar0000000000000000module ListSpec where import Control.Applicative 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 False mdls `shouldContain` ["Data.Map"] ghc-mod-5.8.0.0/test/MonadSpec.hs0000644000000000000000000000276013112432356014557 0ustar0000000000000000module MonadSpec where import Test.Hspec import TestUtils 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, _h) <- runGmOutDef $ runGhcModT defaultOptions $ do Just _ <- return Nothing return "hello" `catchError` (const $ fail "oh noes") a `shouldBe` (Left $ GMEString "oh noes") describe "runGhcModT" $ it "throws an exception when run in multiple threads" $ do mv_ex :: MVar (Either SomeException ()) <- newEmptyMVar mv_startup_barrier :: MVar () <- newEmptyMVar _t1 <- forkOS $ do -- wait (inside GhcModT) for t2 to receive the exception _ <- runD $ liftIO $ do putMVar mv_startup_barrier () readMVar mv_ex 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 ghc-mod-5.8.0.0/test/PathsAndFilesSpec.hs0000644000000000000000000000355513112432356016211 0ustar0000000000000000module 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 ghc-mod-5.8.0.0/test/ShellParseSpec.hs0000644000000000000000000000246213112432356015562 0ustar0000000000000000module 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` [""] ghc-mod-5.8.0.0/test/TargetSpec.hs0000644000000000000000000000306113112432356014742 0ustar0000000000000000{-# 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") ghc-mod-5.8.0.0/test/doctests.hs0000644000000000000000000000143313112432356014532 0ustar0000000000000000{-# LANGUAGE CPP #-} module Main where import Test.DocTest import System.Environment import Data.Maybe main :: IO () 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" ] ghc-mod-5.8.0.0/test/data/0000755000000000000000000000000013112432356013256 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/annotations/0000755000000000000000000000000013112432356015613 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/annotations/With.hs0000644000000000000000000000016613112432356017065 0ustar0000000000000000module Main where {-# ANN module ["this", "can", "be", "anything"] #-} main :: IO () main = putStrLn "Hello world!" ghc-mod-5.8.0.0/test/data/broken-cabal/0000755000000000000000000000000013112432356015576 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/broken-cabal/broken.cabal0000644000000000000000000000001513112432356020036 0ustar0000000000000000broken cabal ghc-mod-5.8.0.0/test/data/broken-sandbox/0000755000000000000000000000000013112432356016172 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/broken-sandbox/cabal.sandbox.config0000644000000000000000000000000713112432356022055 0ustar0000000000000000broken ghc-mod-5.8.0.0/test/data/broken-sandbox/dummy.cabal0000644000000000000000000000000613112432356020305 0ustar0000000000000000dummy ghc-mod-5.8.0.0/test/data/cabal-flags/0000755000000000000000000000000013112432356015412 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/cabal-flags/cabal-flags.cabal0000644000000000000000000000030113112432356020524 0ustar0000000000000000name: cabal-flags version: 0.1.0 build-type: Simple cabal-version: >= 1.8 flag test-flag default: False library build-depends: base if flag(test-flag) build-depends: Cabal >= 1.10 ghc-mod-5.8.0.0/test/data/cabal-project/0000755000000000000000000000000013112432356015764 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/cabal-project/cabalapi.cabal0000644000000000000000000000471013112432356020506 0ustar0000000000000000Name: ghc-mod Version: 1.11.3 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 License-File: LICENSE Homepage: http://www.mew.org/~kazu/proj/ghc-mod/ Synopsis: Happy Haskell programming on Emacs/Vim Description: This packages includes Elisp files and a Haskell command, "ghc-mod". "ghc*.el" enable completion of Haskell symbols on Emacs. Flymake is also integrated. "ghc-mod" is a backend of "ghc*.el". It lists up all installed modules or extracts names of functions, classes, and data declarations. To use "ghc-mod" on Vim, see or Category: Development Cabal-Version: >= 1.6 Build-Type: Simple Data-Dir: elisp Data-Files: Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el ghc-flymake.el ghc-command.el ghc-info.el ghc-ins-mod.el ghc-indent.el Executable ghc-mod Main-Is: GHCMod.hs Other-Modules: Browse CabalApi Cabal CabalDev Check ErrMsg Flag GHCApi GHCChoice Gap Info Lang Lint List Paths_ghc_mod Types GHC-Options: -Wall Build-Depends: base , Cabal >= 1.10 , template-haskell Test-Suite spec Main-Is: Spec.hs Hs-Source-Dirs: test, . Type: exitcode-stdio-1.0 Other-Modules: Expectation BrowseSpec CabalApiSpec FlagSpec LangSpec LintSpec ListSpec Build-Depends: base , Cabal >= 1.10 Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/ghc-mod.git ghc-mod-5.8.0.0/test/data/cabal-project/Baz.hs0000644000000000000000000000014313112432356017032 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} module Baz (baz) where import Foo (fooQ) baz = [fooQ| foo bar baz |] ghc-mod-5.8.0.0/test/data/cabal-project/Foo.hs0000644000000000000000000000034313112432356017043 0ustar0000000000000000module 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 ghc-mod-5.8.0.0/test/data/cabal-project/Info.hs0000644000000000000000000000022613112432356017213 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} -- for HscInterpreted module Info () where fib :: Int -> Int fib 0 = 0 fib 1 = 1 fib n = fib (n - 1) + fib (n - 2) ghc-mod-5.8.0.0/test/data/cabal-project/Main.hs0000644000000000000000000000004613112432356017204 0ustar0000000000000000import Bar (bar) main = putStrLn bar ghc-mod-5.8.0.0/test/data/cabal-project/.cabal-sandbox/0000755000000000000000000000000013112432356020540 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/0000755000000000000000000000000013112432356026172 5ustar0000000000000000i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf0000644000000000000000000000014013112432356035131 0ustar0000000000000000ghc-mod-5.8.0.0/test/data/cabal-project/.cabal-sandboxname: Cabal version: 1.18.1.3 id: Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b exposed: True ghc-mod-5.8.0.0/test/data/cabal-project/subdir1/0000755000000000000000000000000013112432356017335 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/cabal-project/subdir1/subdir2/0000755000000000000000000000000013112432356020707 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/cabal-project/subdir1/subdir2/dummy0000644000000000000000000000000613112432356021761 0ustar0000000000000000dummy ghc-mod-5.8.0.0/test/data/case-split/0000755000000000000000000000000013112432356015322 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/case-split/Crash.hs0000644000000000000000000000006713112432356016721 0ustar0000000000000000module Crash where test :: Maybe a test x = undefined ghc-mod-5.8.0.0/test/data/case-split/Vect706.hs0000644000000000000000000000201013112432356017005 0ustar0000000000000000{-# 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 ghc-mod-5.8.0.0/test/data/case-split/Vect.hs0000644000000000000000000000204313112432356016556 0ustar0000000000000000{-# 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 ghc-mod-5.8.0.0/test/data/check-packageid/0000755000000000000000000000000013112432356016241 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/check-packageid/.cabal-sandbox/0000755000000000000000000000000013112432356021015 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/0000755000000000000000000000000013112432356026447 5ustar0000000000000000i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf0000644000000000000000000000016413112432356037771 0ustar0000000000000000ghc-mod-5.8.0.0/test/data/check-packageid/.cabal-sandboxname: template-haskell version: 2.8.0.0 id: template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c exposed: True ghc-mod-5.8.0.0/test/data/check-test-subdir/0000755000000000000000000000000013112432356016576 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/check-test-subdir/check-test-subdir.cabal0000644000000000000000000000047113112432356023104 0ustar0000000000000000name: check-test-subdir version: 0.1.0 build-type: Simple cabal-version: >= 1.8 library build-depends: base == 4.* hs-source-dirs: src exposed-modules: Check.Test.Subdir test-suite test type: exitcode-stdio-1.0 build-depends: base == 4.* hs-source-dirs: test main-is: Main.hs ghc-options: -Wall ghc-mod-5.8.0.0/test/data/check-test-subdir/src/0000755000000000000000000000000013112432356017365 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/check-test-subdir/src/Check/0000755000000000000000000000000013112432356020402 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/check-test-subdir/src/Check/Test/0000755000000000000000000000000013112432356021321 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/check-test-subdir/src/Check/Test/Subdir.hs0000644000000000000000000000011413112432356023101 0ustar0000000000000000module Check.Test.Subdir (subdir) where subdir :: String subdir = "subdir" ghc-mod-5.8.0.0/test/data/check-test-subdir/test/0000755000000000000000000000000013112432356017555 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/check-test-subdir/test/Foo.hs0000644000000000000000000000004413112432356020632 0ustar0000000000000000module Foo (foo) where foo = "foo" ghc-mod-5.8.0.0/test/data/check-test-subdir/test/Main.hs0000644000000000000000000000011213112432356020767 0ustar0000000000000000module Main where import Bar.Baz (baz) main :: IO () main = putStrLn baz ghc-mod-5.8.0.0/test/data/check-test-subdir/test/Bar/0000755000000000000000000000000013112432356020261 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/check-test-subdir/test/Bar/Baz.hs0000644000000000000000000000012613112432356021330 0ustar0000000000000000module Bar.Baz (baz) where import Foo (foo) baz :: String baz = unwords [foo, "baz"] ghc-mod-5.8.0.0/test/data/duplicate-pkgver/0000755000000000000000000000000013112432356016524 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/duplicate-pkgver/duplicate-pkgver.cabal0000644000000000000000000000016513112432356022760 0ustar0000000000000000name: duplicate-pkgver version: 0.1.0 build-type: Simple cabal-version: >= 1.8 library build-depends: base == 4.* ghc-mod-5.8.0.0/test/data/duplicate-pkgver/.cabal-sandbox/0000755000000000000000000000000013112432356021300 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/0000755000000000000000000000000013112432356026732 5ustar0000000000000000i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-1.0-7c59d13f32294d1ef6dc6233c24df961.conf0000644000000000000000000000015413112432356037557 0ustar0000000000000000ghc-mod-5.8.0.0/test/data/duplicate-pkgver/.cabal-sandboxname: template-haskell version: 1.0 id: template-haskell-1.0-7c59d13f32294d1ef6dc6233c24df961 exposed: True i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-14e543bdae2da4d2aeff5386892c9112.conf0000644000000000000000000000016413112432356040213 0ustar0000000000000000ghc-mod-5.8.0.0/test/data/duplicate-pkgver/.cabal-sandboxname: template-haskell version: 2.8.0.0 id: template-haskell-2.8.0.0-14e543bdae2da4d2aeff5386892c9112 exposed: True i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf0000644000000000000000000000016413112432356040254 0ustar0000000000000000ghc-mod-5.8.0.0/test/data/duplicate-pkgver/.cabal-sandboxname: template-haskell version: 2.8.0.0 id: template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c exposed: True ghc-mod-5.8.0.0/test/data/foreign-export/0000755000000000000000000000000013112432356016226 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/foreign-export/ForeignExport.hs0000644000000000000000000000023113112432356021351 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} module ForeignExport where import Foreign.C.Types foreign export ccall foo :: CUInt foo :: CUInt foo = 123 ghc-mod-5.8.0.0/test/data/ghc-mod-check/0000755000000000000000000000000013112432356015647 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/ghc-mod-check/ghc-mod-check.cabal0000644000000000000000000000130013112432356021216 0ustar0000000000000000-- Initial ghc-mod-check.cabal generated by cabal init. For further -- documentation, see http://haskell.org/cabal/users-guide/ name: ghc-mod-check version: 0.1.0.0 synopsis: check test -- description: license: BSD3 license-file: LICENSE author: Kazu Yamamoto maintainer: kazu@iij.ad.jp -- copyright: category: Data build-type: Simple cabal-version: >=1.8 library HS-Source-Dirs: lib build-depends: base exposed-modules: Data.Foo executable foo Main-Is: main.hs GHC-Options: -Wall Build-Depends: base , ghc-mod-check ghc-mod-5.8.0.0/test/data/ghc-mod-check/main.hs0000644000000000000000000000006513112432356017130 0ustar0000000000000000module Main where import Data.Foo main = print foo ghc-mod-5.8.0.0/test/data/ghc-mod-check/lib/0000755000000000000000000000000013112432356016415 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/ghc-mod-check/lib/Data/0000755000000000000000000000000013112432356017266 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/ghc-mod-check/lib/Data/Foo.hs0000644000000000000000000000027313112432356020347 0ustar0000000000000000module 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) ghc-mod-5.8.0.0/test/data/hlint/0000755000000000000000000000000013112432356014374 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/hlint/hlint.hs0000644000000000000000000000011113112432356016037 0ustar0000000000000000module Hlist where main :: IO () main = do putStrLn "Hello, world!" ghc-mod-5.8.0.0/test/data/home-module-graph/0000755000000000000000000000000013112432356016570 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/home-module-graph/cpp/0000755000000000000000000000000013112432356017352 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/home-module-graph/cpp/A1.hs0000644000000000000000000000006413112432356020147 0ustar0000000000000000{-# LANGUAGE CPP #-} module A1 where #elif import B ghc-mod-5.8.0.0/test/data/home-module-graph/cpp/A2.hs0000644000000000000000000000002013112432356020140 0ustar0000000000000000module A2 where ghc-mod-5.8.0.0/test/data/home-module-graph/cpp/A3.hs0000644000000000000000000000003113112432356020143 0ustar0000000000000000module A3 where import B ghc-mod-5.8.0.0/test/data/home-module-graph/cpp/A.hs0000644000000000000000000000005513112432356020066 0ustar0000000000000000module A where import A1 import A2 import A3 ghc-mod-5.8.0.0/test/data/home-module-graph/cpp/B.hs0000644000000000000000000000001713112432356020065 0ustar0000000000000000module B where ghc-mod-5.8.0.0/test/data/home-module-graph/cycle/0000755000000000000000000000000013112432356017667 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/home-module-graph/cycle/A.hs0000644000000000000000000000003013112432356020374 0ustar0000000000000000module A where import B ghc-mod-5.8.0.0/test/data/home-module-graph/cycle/B.hs0000644000000000000000000000003013112432356020375 0ustar0000000000000000module B where import A ghc-mod-5.8.0.0/test/data/home-module-graph/errors/0000755000000000000000000000000013112432356020104 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/home-module-graph/errors/A1.hs0000644000000000000000000000005713112432356020703 0ustar0000000000000000module A1 where psogduapzs9 import B lx,vLMCks ghc-mod-5.8.0.0/test/data/home-module-graph/errors/A2.hs0000644000000000000000000000002013112432356020672 0ustar0000000000000000module A2 where ghc-mod-5.8.0.0/test/data/home-module-graph/errors/A3.hs0000644000000000000000000000003113112432356020675 0ustar0000000000000000module A3 where import B ghc-mod-5.8.0.0/test/data/home-module-graph/errors/A.hs0000644000000000000000000000005513112432356020620 0ustar0000000000000000module A where import A1 import A2 import A3 ghc-mod-5.8.0.0/test/data/home-module-graph/errors/B.hs0000644000000000000000000000001713112432356020617 0ustar0000000000000000module B where ghc-mod-5.8.0.0/test/data/home-module-graph/indirect/0000755000000000000000000000000013112432356020371 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/home-module-graph/indirect/A1.hs0000644000000000000000000000003113112432356021160 0ustar0000000000000000module A1 where import B ghc-mod-5.8.0.0/test/data/home-module-graph/indirect/A2.hs0000644000000000000000000000003113112432356021161 0ustar0000000000000000module A2 where import C ghc-mod-5.8.0.0/test/data/home-module-graph/indirect/A3.hs0000644000000000000000000000003113112432356021162 0ustar0000000000000000module A3 where import B ghc-mod-5.8.0.0/test/data/home-module-graph/indirect/A.hs0000644000000000000000000000005513112432356021105 0ustar0000000000000000module A where import A1 import A2 import A3 ghc-mod-5.8.0.0/test/data/home-module-graph/indirect/B.hs0000644000000000000000000000001713112432356021104 0ustar0000000000000000module B where ghc-mod-5.8.0.0/test/data/home-module-graph/indirect/C.hs0000644000000000000000000000001713112432356021105 0ustar0000000000000000module C where ghc-mod-5.8.0.0/test/data/home-module-graph/indirect-update/0000755000000000000000000000000013112432356021651 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/home-module-graph/indirect-update/A1.hs0000644000000000000000000000003113112432356022440 0ustar0000000000000000module A1 where import B ghc-mod-5.8.0.0/test/data/home-module-graph/indirect-update/A2.hs0000644000000000000000000000002013112432356022437 0ustar0000000000000000module A2 where ghc-mod-5.8.0.0/test/data/home-module-graph/indirect-update/A3.hs0000644000000000000000000000003113112432356022442 0ustar0000000000000000module A3 where import B ghc-mod-5.8.0.0/test/data/home-module-graph/indirect-update/A.hs0000644000000000000000000000005513112432356022365 0ustar0000000000000000module A where import A1 import A2 import A3 ghc-mod-5.8.0.0/test/data/home-module-graph/indirect-update/B.hs0000644000000000000000000000001713112432356022364 0ustar0000000000000000module B where ghc-mod-5.8.0.0/test/data/home-module-graph/indirect-update/C.hs0000644000000000000000000000001713112432356022365 0ustar0000000000000000module C where ghc-mod-5.8.0.0/test/data/import-cycle/0000755000000000000000000000000013112432356015665 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/import-cycle/Mutual1.hs0000644000000000000000000000013513112432356017550 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} -- for HscInterpreted module Mutual1 where import Mutual2 ghc-mod-5.8.0.0/test/data/import-cycle/Mutual2.hs0000644000000000000000000000004513112432356017551 0ustar0000000000000000module Mutual2 where import Mutual1 ghc-mod-5.8.0.0/test/data/non-exported/0000755000000000000000000000000013112432356015700 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/non-exported/Fib.hs0000644000000000000000000000022513112432356016733 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} -- for HscInterpreted module Fib () where fib :: Int -> Int fib 0 = 0 fib 1 = 1 fib n = fib (n - 1) + fib (n - 2) ghc-mod-5.8.0.0/test/data/pattern-synonyms/0000755000000000000000000000000013112432356016630 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/pattern-synonyms/pattern-synonyms.cabal0000644000000000000000000000134513112432356023171 0ustar0000000000000000-- 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: license-file: LICENSE author: Daniel Gröber maintainer: dxld@darkboxed.org -- copyright: -- category: build-type: Simple -- extra-source-files: cabal-version: >=1.10 library exposed-modules: A, B -- other-modules: other-extensions: PatternSynonyms build-depends: base -- hs-source-dirs: default-language: Haskell2010 ghc-options: -Wall if impl(ghc >= 8.0.1) ghc-options: -Wno-missing-pattern-synonym-signaturesghc-mod-5.8.0.0/test/data/pattern-synonyms/A.hs0000644000000000000000000000017213112432356017344 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module A where data SomeType a b = SomeType (a,b) pattern MyPat x y <- SomeType (x,y) ghc-mod-5.8.0.0/test/data/pattern-synonyms/B.hs0000644000000000000000000000023313112432356017343 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module B where import A foo :: SomeType Int Char -> String foo x = case x of MyPat a b -> show a ++ " " ++ [b] ghc-mod-5.8.0.0/test/data/pattern-synonyms/Setup.hs0000644000000000000000000000005613112432356020265 0ustar0000000000000000import Distribution.Simple main = defaultMain ghc-mod-5.8.0.0/test/data/quasi-quotes/0000755000000000000000000000000013112432356015716 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/quasi-quotes/FooQ.hs0000644000000000000000000000027613112432356017123 0ustar0000000000000000module FooQ (fooQ) where import Language.Haskell.TH import Language.Haskell.TH.Quote (QuasiQuoter(..)) fooQ :: QuasiQuoter fooQ = QuasiQuoter (litE . stringL) undefined undefined undefined ghc-mod-5.8.0.0/test/data/quasi-quotes/QuasiQuotes.hs0000644000000000000000000000014013112432356020530 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} module QuasiQuotes where import FooQ bar = [fooQ| foo bar baz |] ghc-mod-5.8.0.0/test/data/template-haskell/0000755000000000000000000000000013112432356016512 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/template-haskell/Bar.hs0000644000000000000000000000013613112432356017552 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Bar (bar) where import Foo (foo) bar = $foo ++ "bar" ghc-mod-5.8.0.0/test/data/template-haskell/Foo.hs0000644000000000000000000000034313112432356017571 0ustar0000000000000000module 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 ghc-mod-5.8.0.0/test/data/template-haskell/ImportsTH.hs0000644000000000000000000000004613112432356020737 0ustar0000000000000000import Bar (bar) main = putStrLn bar ghc-mod-5.8.0.0/test/data/target/0000755000000000000000000000000013112432356014544 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/target/Cpp.hs0000644000000000000000000000015313112432356015621 0ustar0000000000000000{-# LANGUAGE CPP #-} #undef NOTHING #ifdef NOTHING module WRONG_MODULE where #else module Cpp where #endif ghc-mod-5.8.0.0/test/data/check-missing-warnings/0000755000000000000000000000000013112432356017630 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/check-missing-warnings/DesugarWarnings.hs0000644000000000000000000000013213112432356023263 0ustar0000000000000000module Warnings (zoo) where zoo :: [a] -> () zoo x = case x of [] -> undefined ghc-mod-5.8.0.0/test/data/custom-cradle/0000755000000000000000000000000013112432356016020 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/custom-cradle/custom-cradle.cabal0000644000000000000000000000044713112432356021553 0ustar0000000000000000name: 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: Haskell2010ghc-mod-5.8.0.0/test/data/custom-cradle/ghc-mod.package-db-stack0000644000000000000000000000006313112432356022340 0ustar0000000000000000global user package-db-a package-db-b package-db-c ghc-mod-5.8.0.0/test/data/custom-cradle/package-db-a/0000755000000000000000000000000013112432356020214 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/custom-cradle/package-db-a/.gitkeep0000644000000000000000000000000013112432356021633 0ustar0000000000000000ghc-mod-5.8.0.0/test/data/custom-cradle/package-db-b/0000755000000000000000000000000013112432356020215 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/custom-cradle/package-db-b/.gitkeep0000644000000000000000000000000013112432356021634 0ustar0000000000000000ghc-mod-5.8.0.0/test/data/custom-cradle/package-db-c/0000755000000000000000000000000013112432356020216 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/custom-cradle/package-db-c/.gitkeep0000644000000000000000000000000013112432356021635 0ustar0000000000000000ghc-mod-5.8.0.0/test/data/cabal-preprocessors/0000755000000000000000000000000013112432356017227 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/cabal-preprocessors/cabal-preprocessors.cabal0000644000000000000000000000061313112432356024164 0ustar0000000000000000name: 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: -Wallghc-mod-5.8.0.0/test/data/cabal-preprocessors/Main.hs0000644000000000000000000000007113112432356020445 0ustar0000000000000000import Preprocessed main :: IO () main = return warning ghc-mod-5.8.0.0/test/data/cabal-preprocessors/Preprocessed.hsc0000644000000000000000000000005013112432356022357 0ustar0000000000000000module Preprocessed where warning = () ghc-mod-5.8.0.0/test/data/file-mapping/0000755000000000000000000000000013112432356015626 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/file-mapping/File.hs0000644000000000000000000000005513112432356017041 0ustar0000000000000000main :: IO () main = putStrLn "Hello World!" ghc-mod-5.8.0.0/test/data/file-mapping/File_Redir.hs0000644000000000000000000000003713112432356020166 0ustar0000000000000000main = putStrLn "Hello World!" ghc-mod-5.8.0.0/test/data/file-mapping/File_Redir_Lint.hs0000644000000000000000000000010313112432356021146 0ustar0000000000000000module File where func :: Num a => a -> a -> a func a b = (*) a b ghc-mod-5.8.0.0/test/data/file-mapping/preprocessor/0000755000000000000000000000000013112432356020354 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/file-mapping/preprocessor/File.hs0000644000000000000000000000014713112432356021571 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef NOTHING main :: IO () main = putStrLn "Hello World!" #else INVALID #endif ghc-mod-5.8.0.0/test/data/file-mapping/preprocessor/File_Redir.hs0000644000000000000000000000013113112432356022707 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef NOTHING main = putStrLn "Hello World!" #else INVALID #endif ghc-mod-5.8.0.0/test/data/file-mapping/preprocessor/File_Redir_Lint.hs0000644000000000000000000000017513112432356023705 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef NOTHING module File where func :: Num a => a -> a -> a func a b = (*) a b #else INVALID #endif ghc-mod-5.8.0.0/test/data/file-mapping/lhs/0000755000000000000000000000000013112432356016414 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/file-mapping/lhs/File.lhs0000644000000000000000000000006113112432356020000 0ustar0000000000000000> main :: IO () > main = putStrLn "Hello World!" ghc-mod-5.8.0.0/test/data/file-mapping/lhs/File_Redir.lhs0000644000000000000000000000004113112432356021123 0ustar0000000000000000> main = putStrLn "Hello World!" ghc-mod-5.8.0.0/test/data/file-mapping/lhs/File_Redir_Lint.lhs0000644000000000000000000000011113112432356022107 0ustar0000000000000000> module File where > func :: Num a => a -> a -> a > func a b = (*) a b ghc-mod-5.8.0.0/test/data/nice-qualification/0000755000000000000000000000000013112432356017022 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/nice-qualification/NiceQualification.hs0000644000000000000000000000006513112432356022746 0ustar0000000000000000module Main where main :: IO () main = "wrong type" ghc-mod-5.8.0.0/test/data/stack-project/0000755000000000000000000000000013112432356016027 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/stack-project/stack.yaml.in0000644000000000000000000000005113112432356020421 0ustar0000000000000000flags: {} packages: - '.' extra-deps: [] ghc-mod-5.8.0.0/test/data/stack-project/new-template.cabal0000644000000000000000000000234513112432356021421 0ustar0000000000000000name: 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 ghc-mod-5.8.0.0/test/data/stack-project/Setup.hs0000644000000000000000000000005613112432356017464 0ustar0000000000000000import Distribution.Simple main = defaultMain ghc-mod-5.8.0.0/test/data/stack-project/app/0000755000000000000000000000000013112432356016607 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/stack-project/app/Main.hs0000644000000000000000000000007513112432356020031 0ustar0000000000000000module Main where import Lib main :: IO () main = someFunc ghc-mod-5.8.0.0/test/data/stack-project/src/0000755000000000000000000000000013112432356016616 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/stack-project/src/Lib.hs0000644000000000000000000000013013112432356017652 0ustar0000000000000000module Lib ( someFunc ) where someFunc :: IO () someFunc = putStrLn "someFunc" ghc-mod-5.8.0.0/test/data/stack-project/test/0000755000000000000000000000000013112432356017006 5ustar0000000000000000ghc-mod-5.8.0.0/test/data/stack-project/test/Spec.hs0000644000000000000000000000007713112432356020240 0ustar0000000000000000main :: IO () main = putStrLn "Test suite not yet implemented" ghc-mod-5.8.0.0/bench/0000755000000000000000000000000013112432356012445 5ustar0000000000000000ghc-mod-5.8.0.0/bench/Bench.hs0000644000000000000000000000142213112432356014017 0ustar0000000000000000import 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 () ghc-mod-5.8.0.0/bench/data/0000755000000000000000000000000013112432356013356 5ustar0000000000000000ghc-mod-5.8.0.0/bench/data/simple-cabal/0000755000000000000000000000000013112432356015707 5ustar0000000000000000ghc-mod-5.8.0.0/bench/data/simple-cabal/simple-cabal.cabal0000644000000000000000000000056113112432356021226 0ustar0000000000000000name: 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 ghc-mod-5.8.0.0/bench/data/simple-cabal/Main.hs0000644000000000000000000000010313112432356017121 0ustar0000000000000000module Main where main :: IO () main = putStrLn "Hello, Haskell!" ghc-mod-5.8.0.0/bench/data/simple-cabal/Setup.hs0000644000000000000000000000005613112432356017344 0ustar0000000000000000import Distribution.Simple main = defaultMain ghc-mod-5.8.0.0/elisp/0000755000000000000000000000000013112432356012502 5ustar0000000000000000ghc-mod-5.8.0.0/elisp/Makefile0000644000000000000000000000252613112432356014147 0ustar0000000000000000SRCS = 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 TEMPFILE = temp.el TEMPFILE2 = temp2.el all: $(TEMPFILE) ghc.el $(EMACS) -batch -q -no-site-file -l ./$(TEMPFILE) -f ghc-compile rm -f $(TEMPFILE) 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) @echo '(defun ghc-compile () (mapcar (lambda (x) (byte-compile-file x)) (list ' >> $(TEMPFILE) @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) $(TEMPFILE2) VERSION = `grep version ghc.el | sed -e 's/[^0-9\.]//g'` bump: echo "(define-package\n \"ghc-mod\"\n $(VERSION)\n \"Sub mode for Haskell mode\"\n nil)" > ghc-pkg.el archive: git archive master -o ~/ghc-$(VERSION).tar --prefix=ghc-$(VERSION)/ ghc-mod-5.8.0.0/elisp/ghc-doc.el0000644000000000000000000000756413112432356014344 0ustar0000000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ghc.el ;;; ;; Author: Kazu Yamamoto ;; Created: Sep 25, 2009 (require 'ghc-func) (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) (interactive "P") (let ((mod0 (ghc-extract-module)) (expr0 (ghc-things-at-point)) pkg-ver-path mod expr info) (if (or mod0 (not expr0)) (setq mod (ghc-read-module-name mod0)) (setq expr (ghc-read-expression expr0)) (setq info (ghc-get-info expr0)) (setq mod (ghc-extact-module-from-info info))) (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 documentation found")))) (ghc-defstruct pkg-ver-path pkg ver path) (defun ghc-resolve-document-path (mod) (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* ((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)) (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))) (funcall ghc-doc-browser-function url))) (defun ghc-add-anchor (url symbol) (let ((case-fold-search nil)) (if (string-match "^[A-Z]" symbol) (concat url "#t:" symbol) (if (string-match "^[a-z]" symbol) (concat url "#v:" symbol) (concat url "#v:" (ghc-url-encode symbol)))))) (defun ghc-url-encode (symbol) (let ((len (length symbol)) (i 0) acc) (while (< i len) (ghc-add acc (format "-%d-" (aref symbol i))) (setq i (1+ i))) (apply 'concat (nreverse acc)))) (defun ghc-extact-module-from-info (info) (when (string-match "[`\u2018]\\([^'\u2019]+\\)['\u2019]" info) (match-string 1 info))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar ghc-input-map nil) (unless ghc-input-map (setq ghc-input-map (if (boundp 'minibuffer-local-map) (copy-keymap minibuffer-local-map) (make-sparse-keymap))) (define-key ghc-input-map "\t" 'ghc-complete)) (defun ghc-read-module-name (def) (read-from-minibuffer "Module name: " def ghc-input-map)) (defun ghc-read-expression (def) (read-from-minibuffer "Identifier: " def ghc-input-map)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ghc-extract-module () (interactive) (save-excursion (beginning-of-line) (if (looking-at "^\\(import\\|module\\) +\\(qualified +\\)?\\([^ (\n]+\\)") (match-string-no-properties 3)))) (provide 'ghc-doc) ghc-mod-5.8.0.0/elisp/ghc-indent.el0000644000000000000000000000075713112432356015055 0ustar0000000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ghc-indent.el ;;; ;; Author: Kazu Yamamoto ;; Created: Feb 28, 2012 ;;; Code: (defvar ghc-indent-offset 4) (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) (interactive "r") (indent-rigidly (region-beginning) (region-end) ghc-indent-offset)) (provide 'ghc-indent) ghc-mod-5.8.0.0/elisp/ghc-ins-mod.el0000644000000000000000000000420113112432356015126 0ustar0000000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ghc-ins-mod.el ;;; ;; Author: Kazu Yamamoto ;; Created: Dec 27, 2011 (require 'ghc-process) ;;; Code: (defun ghc-insert-module () (interactive) (let* ((expr0 (ghc-things-at-point)) (expr (ghc-read-expression expr0))) (ghc-ins-mod expr))) (defvar ghc-preferred-modules '("Control.Applicative" "Data.ByteString" "Data.Text" "Text.Parsec" "System.FilePath" "System.Directory")) (defun ghc-reorder-modules (mods) (catch 'loop (dolist (pmod ghc-preferred-modules) (if (member pmod mods) (throw 'loop (cons pmod (delete pmod mods))))) mods)) (defun ghc-ins-mod (expr) (let (prefix fun mods) (if (not (string-match "^\\([^.]+\\)\\\.\\([^.]+\\)$" expr)) (setq fun expr) (setq prefix (match-string 1 expr)) (setq fun (match-string 2 expr))) (setq mods (ghc-reorder-modules (ghc-function-to-modules fun))) (if (null mods) (message "No module guessed") (let* ((key (or prefix fun)) (fmt (concat "Module name for \"" key "\" (%s): ")) (mod (ghc-completing-read fmt mods))) (save-excursion (ghc-goto-module-position) (if prefix (insert-before-markers "import qualified " mod " as " prefix "\n") (insert-before-markers "import " mod " (" (ghc-enclose expr) ")\n"))))))) (defun ghc-completing-read (fmt lst) (let* ((def (car lst)) (prompt (format fmt def)) (inp (completing-read prompt lst))) (if (string= inp "") def inp))) (defun ghc-goto-module-position () (goto-char (point-max)) (if (re-search-backward "^import +" nil t) (ghc-goto-empty-line) (if (not (re-search-backward "^module" nil t)) (goto-char (point-min)) (ghc-goto-empty-line) (forward-line) (unless (eolp) ;; save-excursion is not proper due to insert-before-markers. (let ((beg (point))) (insert-before-markers "\n") (goto-char beg)))))) (defun ghc-goto-empty-line () (unless (re-search-forward "^$" nil t) (forward-line))) (defun ghc-function-to-modules (fun) (let ((cmd (format "find %s\n" fun))) (ghc-sync-process cmd))) (provide 'ghc-ins-mod) ghc-mod-5.8.0.0/elisp/ghc-pkg.el0000644000000000000000000000013213112432356014340 0ustar0000000000000000(define-package "ghc" 2.0.0 "Sub mode for Haskell mode" '((haskell-mode "13.0"))) ghc-mod-5.8.0.0/elisp/ghc-rewrite.el0000644000000000000000000001551213112432356015250 0ustar0000000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ghc-rewrite.el ;;; ;; Author: Alejandro Serrano ;; Created: Jun 17, 2014 ;;; Code: (require 'ghc-func) (require 'ghc-process) (require 'button) ;(require 'dropdown-list) (defvar ghc-auto-info nil) (defvar ghc-auto-buffer nil) ;; Common code for case splitting and refinement (defun ghc-perform-rewriting (info) "Replace code with new string obtained from ghc-mod" (let* ((current-line (line-number-at-pos)) (begin-line (ghc-sinfo-get-beg-line info)) (begin-line-diff (+ 1 (- begin-line current-line))) (begin-line-pos (line-beginning-position begin-line-diff)) (begin-pos (- (+ begin-line-pos (ghc-sinfo-get-beg-column info)) 1)) (end-line (ghc-sinfo-get-end-line info)) (end-line-diff (+ 1 (- end-line current-line))) (end-line-pos (line-beginning-position end-line-diff)) (end-pos (- (+ end-line-pos (ghc-sinfo-get-end-column info)) 1)) ) (delete-region begin-pos end-pos) (insert (ghc-sinfo-get-info info)) ) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Case splitting ;;; (ghc-defstruct sinfo beg-line beg-column end-line end-column info) (defun ghc-case-split () "Split the variable at point into its possible constructors" (interactive) (when (null (ghc-try-case-split)) (message "Cannot split into cases"))) (defun ghc-try-case-split () (let ((info (ghc-obtain-case-split))) (if (null info) '() (ghc-perform-rewriting info)) )) (defun ghc-obtain-case-split () (let* ((ln (int-to-string (line-number-at-pos))) (cn (int-to-string (1+ (current-column)))) (file (buffer-file-name)) (cmd (format "split %s %s %s\n" file ln cn))) (ghc-sync-process cmd))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Refinement ;;; (defun ghc-refine () "Refine a hole using a user-specified function" (interactive) (when (null (ghc-try-refine)) (message "Cannot refine"))) (defun ghc-try-refine () (let ((info (ghc-obtain-refine (read-string "Refine with: ")))) (if (null info) '() (ghc-perform-rewriting info)) )) (defun ghc-obtain-refine (expr) (let* ((ln (int-to-string (line-number-at-pos))) (cn (int-to-string (1+ (current-column)))) (file (buffer-file-name)) (cmd (format "refine %s %s %s %s\n" file ln cn expr))) (ghc-sync-process cmd))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Auto ;;; (defun ghc-perform-rewriting-auto (info msg) "Replace code with new string obtained from ghc-mod from auto mode" (let* ((current-line (line-number-at-pos)) (begin-line (ghc-sinfo-get-beg-line info)) (begin-line-diff (+ 1 (- begin-line current-line))) (begin-line-pos (line-beginning-position begin-line-diff)) (begin-pos (- (+ begin-line-pos (ghc-sinfo-get-beg-column info)) 1)) (end-line (ghc-sinfo-get-end-line info)) (end-line-diff (+ 1 (- end-line current-line))) (end-line-pos (line-beginning-position end-line-diff)) (end-pos (- (+ end-line-pos (ghc-sinfo-get-end-column info)) 1)) ) (delete-region begin-pos end-pos) (insert msg))) ;; Option 1: using button (defun ghc-auto-completion-window () (get-buffer-window ghc-error-buffer-name 0)) (defun auto-button (button) (let ((text (buffer-substring (button-start button) (button-end button)))) (with-current-buffer ghc-auto-buffer (ghc-perform-rewriting-auto ghc-auto-info text)) (quit-restore-window))) (define-button-type 'auto-button 'follow-link t 'help-echo "mouse-2, RET: Insert this completion" 'action #'auto-button) (defun ghc-show-auto-messages (info) (let ((buf (current-buffer))) (setq ghc-auto-info info) (setq ghc-auto-buffer buf) (ghc-display nil (lambda () (insert "Possible completions:\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)))) ;; Option 2: using dropdown-list ;; (defun ghc-show-auto-messages (info) ;; (let* ((completions (ghc-sinfo-get-info info)) ;; (selected (dropdown-list completions))) ;; (when selected ;; (ghc-perform-rewriting-auto info (nth selected completions))))) ;; Option 3: using minibuffer ;; (defvar ghc-auto-completion-buffer-name "*Djinn Completions*") ;; (defun ghc-auto-completion-window () ;; (get-buffer-window ghc-auto-completion-buffer-name 0)) ;; (defun ghc-show-auto-messages (info) ;; (let* ((completions (ghc-sinfo-get-info info)) ;; (buf (generate-new-buffer "djinn-completion-temp"))) ;; (with-current-buffer ;; (progn ;; (with-output-to-temp-buffer ghc-auto-completion-buffer-name ;; (display-completion-list completions)) ;; (select-window (ghc-auto-completion-window)) ;; (buffer-string))))) (defun ghc-auto () "Try to automatically fill the contents of a hole" (interactive) (let ((info (ghc-obtain-auto))) (if (null info) (message "No automatic completions found") (if (= (length (ghc-sinfo-get-info info)) 1) (ghc-perform-rewriting-auto info (car (ghc-sinfo-get-info info))) (ghc-show-auto-messages info))))) (defun ghc-obtain-auto () (let* ((ln (int-to-string (line-number-at-pos))) (cn (int-to-string (1+ (current-column)))) (file (buffer-file-name)) (cmd (format "auto %s %s %s\n" file ln cn))) (ghc-sync-process cmd))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Initial code from signature ;;; (ghc-defstruct icsinfo sort pos fns) (defun ghc-initial-code-from-signature () "Refine a hole using a user-specified function" (interactive) (when (null (ghc-try-initial-code-from-signature)) (message "Cannot obtain initial code"))) (defun ghc-try-initial-code-from-signature () "Include initial code from a function signature or instance declaration" (interactive) (let ((info (ghc-obtain-initial-code-from-signature))) (if (null info) '() (let* ((ln-current (line-number-at-pos)) (sort (ghc-icsinfo-get-sort info)) (pos (ghc-icsinfo-get-pos info)) (ln-end (ghc-sinfo-get-end-line pos)) (ln-diff (+ 1 (- ln-end ln-current))) (fns-to-insert (ghc-icsinfo-get-fns info))) (goto-char (line-end-position ln-diff)) (dolist (fn-to-insert fns-to-insert) (if (equal sort "function") (newline) (newline-and-indent)) (insert fn-to-insert)))))) (defun ghc-obtain-initial-code-from-signature () (let* ((ln (int-to-string (line-number-at-pos))) (cn (int-to-string (1+ (current-column)))) (file (buffer-file-name)) (cmd (format "sig %s %s %s\n" file ln cn))) (ghc-sync-process cmd))) (provide 'ghc-rewrite) ghc-mod-5.8.0.0/elisp/ghc-check.el0000644000000000000000000004141113112432356014641 0ustar0000000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ghc-check.el ;;; ;; Author: Kazu Yamamoto ;; Created: Mar 9, 2014 ;;; Code: (require 'ghc-func) (require 'ghc-process) (require 'button) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; stolen from flymake.el (defface ghc-face-error '((((supports :underline (:style wave))) :underline (:style wave :color "orangered")) (t :inherit error)) "Face used for error lines." :group 'ghc) (defface ghc-face-warn '((((supports :underline (:style wave))) :underline (:style wave :color "gold")) (t :inherit warning)) "Face used for warning lines." :group 'ghc) (defface ghc-face-hole '((((supports :underline (:style wave))) :underline (:style wave :color "purple")) (t :inherit warning)) "Face used for hole lines." :group 'ghc) (defvar ghc-check-error-fringe (propertize "!" 'display '(left-fringe exclamation-mark))) (defvar ghc-check-warning-fringe (propertize "?" 'display '(left-fringe question-mark))) (defvar ghc-check-hole-fringe (propertize "_" 'display '(left-fringe horizontal-bar))) (defvar ghc-display-error nil "*How to display errors/warnings when using 'M-n' and 'M-p': 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 "*How to display hole information when using 'C-c C-j' and 'C-c C-h' 'minibuffer display errors/warnings in the minibuffer. 'other-buffer display errors/warnings in the a new buffer" ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ghc-check-syntax () (interactive) ;; 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 " -:-"))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (ghc-defstruct hilit-info file line msg err hole coln) (defun ghc-check-send () (let ((file (buffer-file-name))) (if ghc-check-command (let ((opts (ghc-haskell-list-of-string ghc-hlint-options))) (if opts (format "lint %s %s\n" opts file) (format "lint %s\n" file))) (format "check %s\n" file)))) (defun ghc-haskell-list-of-string (los) (when los (concat "[" (mapconcat (lambda (x) (concat "\"" x "\"")) los ", ") "]"))) (defun ghc-check-callback (status) (cond ((eq status 'ok) (let* ((errs (ghc-read-lisp-this-buffer)) (infos (ghc-to-info errs))) (cond (infos (let ((file ghc-process-original-file) (buf ghc-process-original-buffer)) (ghc-check-highlight-original-buffer file buf infos))) (t (ghc-with-current-buffer ghc-process-original-buffer (remove-overlays (point-min) (point-max) 'ghc-check t)))) (ghc-with-current-buffer ghc-process-original-buffer (let ((len (length infos))) (if (= len 0) (setq mode-line-process "") (let* ((errs (ghc-filter 'ghc-hilit-info-get-err infos)) (elen (length errs)) (wlen (- len elen))) (setq mode-line-process (format " %d:%d" elen wlen))))) (force-mode-line-update)))) (t (let* ((err (ghc-unescape-string (buffer-substring-no-properties (+ (point) 3) (point-max)))) (info (ghc-make-hilit-info :file "Fail errors:" :line 0 :coln 0 :msg err :err t :hole nil)) (infos (list info)) (file ghc-process-original-file) (buf ghc-process-original-buffer)) (ghc-check-highlight-original-buffer file buf infos)) (ghc-with-current-buffer ghc-process-original-buffer (setq mode-line-process " failed") (force-mode-line-update))))) (defun ghc-to-info (errs) ;; [^\t] to include \n. (let ((regex "^\\([^\n]*\\):\\([0-9]+\\):\\([0-9]+\\): *\\([^\t]+\\)") infos) (dolist (err errs (nreverse infos)) (when (string-match regex err) (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)) (wrn (string-match "^Warning" msg)) (hole (save-match-data (when (string-match "Found hole .\\(_[_[:alnum:]]*\\)." msg) (match-string 1 msg)))) (info (ghc-make-hilit-info :file file :line line :coln coln :msg msg :err (and (not wrn) (not hole)) :hole hole))) (unless (member info infos) (ghc-add infos info))))))) (defun ghc-check-highlight-original-buffer (ofile buf infos) (ghc-with-current-buffer buf (remove-overlays (point-min) (point-max) 'ghc-check t) (save-excursion (goto-char (point-min)) (dolist (info infos) (let ((line (ghc-hilit-info-get-line info)) (msg (ghc-hilit-info-get-msg info)) (file (ghc-hilit-info-get-file info)) (err (ghc-hilit-info-get-err info)) (hole (ghc-hilit-info-get-hole info)) (coln (ghc-hilit-info-get-coln info)) beg end ovl) ;; FIXME: This is the Shlemiel painter's algorithm. ;; If this is a bottleneck for a large code, let's fix. (goto-char (point-min)) (cond ((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) (setq end (point)))) (setq ovl (make-overlay beg end)) (overlay-put ovl 'ghc-check t) (overlay-put ovl 'ghc-file file) (overlay-put ovl 'ghc-msg msg) (overlay-put ovl 'help-echo msg) (overlay-put ovl 'ghc-hole hole) (let ((fringe (if err ghc-check-error-fringe (if hole ghc-check-hole-fringe ghc-check-warning-fringe))) (face (if err 'ghc-face-error (if hole 'ghc-face-hole 'ghc-face-warn)))) (overlay-put ovl 'before-string fringe) (overlay-put ovl 'face face))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ghc-overlay-p (ovl) (overlay-get ovl 'ghc-check)) (defun ghc-check-overlay-at (p) (ghc-filter 'ghc-overlay-p (overlays-at p))) (ghc-defstruct file-msgs file msgs) (defun ghc-get-errors-over-warnings () (let ((ovls (ghc-check-overlay-at (point)))) (when ovls (let ((msgs (mapcar (lambda (ovl) (overlay-get ovl 'ghc-msg)) ovls)) (file (overlay-get (car ovls) 'ghc-file)) errs wrns) (dolist (msg msgs) (if (string-match "^Warning" msg) (ghc-add wrns msg) (ghc-add errs msg))) (ghc-make-file-msgs :file file :msgs (nconc errs wrns)))))) (defun ghc-display-errors () (interactive) (let ((file-msgs (ghc-get-errors-over-warnings))) (if (null file-msgs) (message "No errors or warnings") (let ((file (ghc-file-msgs-get-file file-msgs)) (msgs (ghc-file-msgs-get-msgs file-msgs))) (ghc-display nil (lambda () (insert file "\n\n") (mapc (lambda (x) (insert x "\n\n")) msgs))))))) (defun ghc-display-errors-to-minibuf () (let ((file-msgs (ghc-get-errors-over-warnings))) (if (null file-msgs) (message "No errors or warnings") (let* ((file (ghc-file-msgs-get-file file-msgs)) (msgs (ghc-file-msgs-get-msgs file-msgs)) (errmsg (mapconcat 'identity msgs "\n")) (buffile buffer-file-name)) (if (string-equal buffile file) (message "%s" errmsg) (message "%s\n\n%s" file errmsg)))))) (defun ghc-get-only-holes () (let ((ovls (ghc-check-overlay-at (point)))) (when ovls (let ((msgs (mapcar (lambda (ovl) (overlay-get ovl 'ghc-msg)) ovls)) (file (overlay-get (car ovls) 'ghc-file)) holes) (dolist (msg msgs) (if (string-match "Found hole" msg) (ghc-add holes msg) nil)) (ghc-make-file-msgs :file file :msgs holes))))) ;; Based on http://superuser.com/questions/331895/how-to-get-emacs-to-highlight-and-link-file-paths (defun find-file-button (button) (let ((text (buffer-substring (button-start button) (button-end button)))) (when (string-match "\\(/[^:]*\\):\\([[:digit:]]+\\):\\([[:digit:]]+\\)" text) (let* ((file (match-string 1 text)) (line (string-to-number (match-string 2 text))) (coln (string-to-number (match-string 3 text))) (buf (find-file file))) (with-current-buffer buf (let* ((this-line (line-number-at-pos)) (diff (- line this-line))) (beginning-of-line) (forward-line diff) (forward-char (1- coln)))))))) (define-button-type 'find-file-button 'follow-link t 'help-echo "mouse-2, RET: Go to definition" 'action #'find-file-button) (defun buttonize-buffer () "turn all file paths into buttons" (save-excursion (goto-char (point-min)) (while (re-search-forward "/[^ \t:]*:[[:digit:]]+:[[:digit:]]+" nil t) (make-button (match-beginning 0) (match-end 0) :type 'find-file-button)))) (defun ghc-display-holes () (interactive) (let ((file-msgs (ghc-get-only-holes))) (if (null file-msgs) (message "No holes") (let ((msgs (ghc-file-msgs-get-msgs file-msgs))) (ghc-display nil (lambda () (progn (mapc (lambda (x) (insert x "\n\n")) msgs) (buttonize-buffer)))))))) (defun ghc-display-holes-to-minibuf () (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)) (errmsg (mapconcat 'identity msgs "\n")) (buffile buffer-file-name)) (if (string-equal buffile file) (message "%s" errmsg) (message "%s\n\n%s" file errmsg)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ghc-goto-prev-error () (interactive) (let* ((here (point)) (ovls0 (ghc-check-overlay-at here)) (end (if ovls0 (overlay-start (car ovls0)) here)) (ovls1 (overlays-in (point-min) end)) (ovls2 (ghc-filter (lambda (ovl) (overlay-get ovl 'ghc-check)) ovls1)) (pnts (mapcar 'overlay-start ovls2))) (if pnts (goto-char (apply 'max pnts)))) (cond ((eq ghc-display-error 'minibuffer) (ghc-display-errors-to-minibuf)) ((eq ghc-display-error 'other-buffer) (ghc-display-errors)))) (defun ghc-goto-next-error () (interactive) (let* ((here (point)) (ovls0 (ghc-check-overlay-at here)) (beg (if ovls0 (overlay-end (car ovls0)) here)) (ovls1 (overlays-in beg (point-max))) (ovls2 (ghc-filter (lambda (ovl) (overlay-get ovl 'ghc-check)) ovls1)) (pnts (mapcar 'overlay-start ovls2))) (if pnts (goto-char (apply 'min pnts)))) (cond ((eq ghc-display-error 'minibuffer) (ghc-display-errors-to-minibuf)) ((eq ghc-display-error 'other-buffer) (ghc-display-errors)))) (defun ghc-goto-prev-hole () (interactive) (let* ((here (point)) (ovls0 (ghc-check-overlay-at here)) (end (if ovls0 (overlay-start (car ovls0)) here)) (ovls1 (overlays-in (point-min) end)) (ovls2 (ghc-filter (lambda (ovl) (overlay-get ovl 'ghc-check)) ovls1)) (ovls3 (ghc-filter (lambda (ovl) (overlay-get ovl 'ghc-hole)) ovls2)) (pnts (mapcar 'overlay-start ovls3))) (if pnts (goto-char (apply 'max pnts)))) (cond ((eq ghc-display-hole 'minibuffer) (ghc-display-holes-to-minibuf)) ((eq ghc-display-hole 'other-buffer) (ghc-display-holes)))) (defun ghc-goto-next-hole () (interactive) (let* ((here (point)) (ovls0 (ghc-check-overlay-at here)) (beg (if ovls0 (overlay-end (car ovls0)) here)) (ovls1 (overlays-in beg (point-max))) (ovls2 (ghc-filter (lambda (ovl) (overlay-get ovl 'ghc-check)) ovls1)) (ovls3 (ghc-filter (lambda (ovl) (overlay-get ovl 'ghc-hole)) ovls2)) (pnts (mapcar 'overlay-start ovls3))) (if pnts (goto-char (apply 'min pnts)))) (cond ((eq ghc-display-hole 'minibuffer) (ghc-display-holes-to-minibuf)) ((eq ghc-display-hole 'other-buffer) (ghc-display-holes)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ghc-check-insert-from-warning () (interactive) (let ((ret t)) (dolist (data (delete-dups (mapcar (lambda (ovl) (overlay-get ovl 'ghc-msg)) (ghc-check-overlay-at (point)))) ret) (save-excursion (cond ((string-match "Inferred type: \\|no type signature:" data) (beginning-of-line) (insert-before-markers (ghc-extract-type data) "\n")) ((string-match "lacks an accompanying binding" data) (beginning-of-line) (when (looking-at "^\\([^ ]+\\) *::") (save-match-data (forward-line) (if (not (bolp)) (insert "\n"))) (insert (match-string 1) " = undefined\n"))) ;; GHC 7.8 uses Unicode for single-quotes. ((string-match "Not in scope: type constructor or class .\\([^\n]+\\)." data) (let ((sym (match-string 1 data))) (ghc-ins-mod sym))) ((string-match "Not in scope: data constructor .\\([^\n]+\\)." data) ;; if the type of data constructor, it would be nice. (let ((sym (match-string 1 data))) (ghc-ins-mod sym))) ((string-match "\n[ ]+.\\([^ ]+\\). is a data constructor of .\\([^\n]+\\).\n" data) (let* ((old (match-string 1 data)) (type-const (match-string 2 data)) (new (format "%s(%s)" type-const old))) (ghc-check-replace old new))) ((string-match "Not in scope: .\\([^\n]+\\)." data) (let ((sym (match-string 1 data))) (if (or (string-match "\\." sym) ;; qualified (y-or-n-p (format "Import module for %s?" sym))) (ghc-ins-mod sym) (unless (re-search-forward "^$" nil t) (goto-char (point-max)) (insert "\n")) (insert "\n" (ghc-enclose sym) " = undefined\n")))) ((string-match "Pattern match(es) are non-exhaustive" data) (let* ((fn (ghc-get-function-name)) (arity (ghc-get-function-arity fn))) (ghc-insert-underscore fn arity))) ((string-match "Found:\n[ ]+\\([^\t]+\\)\nWhy not:\n[ ]+\\([^\t]+\\)" data) (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))))))) (defun ghc-check-replace (old new) (beginning-of-line) (when (search-forward old nil t) (let ((end (point))) (search-backward old nil t) (delete-region (point) end)) (insert new))) (defun ghc-extract-type (str) (with-temp-buffer (insert str) (goto-char (point-min)) (when (re-search-forward "Inferred type: \\|no type signature:\\( \\|\n +\\)?" nil t) (delete-region (point-min) (point))) (when (re-search-forward " forall [^.]+\\." nil t) (replace-match "")) (while (re-search-forward "\n +" nil t) (replace-match " ")) (goto-char (point-min)) (while (re-search-forward "\\[Char\\]" nil t) (replace-match "String")) (buffer-substring-no-properties (point-min) (point-max)))) (defun ghc-get-function-name () (save-excursion (beginning-of-line) (when (looking-at "\\([^ ]+\\) ") (match-string 1)))) (defun ghc-get-function-arity (fn) (when fn (save-excursion (let ((regex (format "^%s *::" (regexp-quote fn)))) (when (re-search-backward regex nil t) (ghc-get-function-arity0)))))) (defun ghc-get-function-arity0 () (let ((end (save-excursion (end-of-line) (point))) (arity 0)) (while (search-forward "->" end t) (setq arity (1+ arity))) arity)) (defun ghc-insert-underscore (fn ar) (when fn (let ((arity (or ar 1))) (save-excursion (goto-char (point-max)) (re-search-backward (format "^%s *::" (regexp-quote fn))) (forward-line) (re-search-forward "^$" nil t) (insert fn) (dotimes (_i arity) (insert " _")) (insert " = error \"" fn "\"\n"))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ghc-jump-file () (interactive) (let* ((ovl (car (ghc-check-overlay-at 1))) (file (if ovl (overlay-get ovl 'ghc-file)))) (if file (find-file file)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar ghc-hlint-options nil "*Hlint options") (defvar ghc-check-command nil) (defun ghc-toggle-check-command () (interactive) (setq ghc-check-command (not ghc-check-command)) (if ghc-check-command (message "Syntax check with hlint") (message "Syntax check with GHC"))) (provide 'ghc-check) ghc-mod-5.8.0.0/elisp/ghc-command.el0000644000000000000000000000515213112432356015204 0ustar0000000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ghc-command.el ;;; ;; Author: Kazu Yamamoto ;; Created: Apr 13, 2010 ;;; Code: (require 'ghc-process) (require 'ghc-check) (defun ghc-insert-template () (interactive) (cond ((bobp) (ghc-insert-module-template)) ((ghc-check-overlay-at (point)) (or (ghc-check-insert-from-warning) (ghc-try-case-split))) (t (unless (ghc-try-case-split) (message "Nothing to be done"))))) (defun ghc-insert-module-template () (let* ((fullname (file-name-sans-extension (buffer-file-name))) (rootdir (ghc-get-project-root)) (len (length rootdir)) (name (substring fullname (1+ len))) (file (file-name-sans-extension (buffer-name))) (case-fold-search nil) (mod (if (string-match "^[A-Z]" name) (ghc-replace-character name ?/ ?.) (if (string-match "^[a-z]" file) "Main" file)))) (while (looking-at "^{-#") (forward-line)) (insert "module " mod " where\n"))) ;; (defun ghc-capitalize (str) ;; (let ((ret (copy-sequence str))) ;; (aset ret 0 (upcase (aref ret 0))) ;; ret)) (defun ghc-sort-lines (beg end) (interactive "r") (save-excursion (save-restriction (narrow-to-region beg end) (goto-char (point-min)) (let ((inhibit-field-text-motion t)) (sort-subr nil 'forward-line 'end-of-line (lambda () (re-search-forward "^import +\\(qualified\\)? *" nil t) nil) 'end-of-line)) (ghc-merge-lines)))) (defun ghc-merge-lines () (let ((case-fold-search nil)) (goto-char (point-min)) (while (not (eolp)) ;; qualified modlues are not merged at this moment. ;; fixme if it is improper. (if (looking-at "^import +\\([A-Z][^ \n]+\\) *(\\(.*\\))$") (let ((mod (match-string-no-properties 1)) (syms (match-string-no-properties 2)) (beg (point))) (forward-line) (ghc-merge-line beg mod syms)) (forward-line))))) (defun ghc-merge-line (beg mod syms) (let ((regex (concat "^import +" (regexp-quote mod) " *(\\(.*\\))$")) duplicated) (while (looking-at regex) (setq duplicated t) (setq syms (concat syms ", " (match-string-no-properties 1))) (forward-line)) (when duplicated (delete-region beg (point)) (insert "import " mod " (" syms ")\n")))) (defun ghc-save-buffer () (interactive) ;; fixme: better way then saving? (if ghc-check-command ;; hlint (if (buffer-modified-p) (call-interactively 'save-buffer)) (unless buffer-read-only (set-buffer-modified-p t) (call-interactively 'save-buffer))) (ghc-check-syntax)) (provide 'ghc-command) ghc-mod-5.8.0.0/elisp/ghc-comp.el0000644000000000000000000001715313112432356014530 0ustar0000000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ghc-comp.el ;;; ;; Author: Kazu Yamamoto ;; Created: Sep 25, 2009 ;;; Code: (require 'ghc-func) (require 'ghc-rewrite) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Customize Variables ;;; (defvar ghc-idle-timer-interval 30 "*Period of idle timer in second. When timeout, the names of unloaded modules are loaded") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Constants ;;; ;; must be sorted (defconst ghc-reserved-keyword-for-bol '("class" "data" "default" "import" "infix" "infixl" "infixr" "instance" "main" "module" "newtype" "type")) ;; must be sorted (defconst ghc-reserved-keyword '("case" "deriving" "do" "else" "if" "in" "let" "module" "of" "then" "where")) (defconst ghc-extra-keywords '("ByteString" "Text")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Local Variables ;;; (defvar ghc-window-configuration nil) (mapc 'make-variable-buffer-local '(ghc-window-configuration)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Initializer ;;; (defvar ghc-module-names nil) ;; completion for "import" (defvar ghc-merged-keyword nil) ;; completion for type/func/... (defvar ghc-language-extensions nil) (defvar ghc-option-flags nil) (defvar ghc-pragma-names '("LANGUAGE" "OPTIONS_GHC" "INCLUDE" "WARNING" "DEPRECATED" "INLINE" "NOINLINE" "ANN" "LINE" "RULES" "SPECIALIZE" "UNPACK" "SOURCE")) (defconst ghc-keyword-prefix "ghc-keyword-") (defvar ghc-keyword-Prelude nil) (defvar ghc-keyword-Control.Applicative nil) (defvar ghc-keyword-Control.Exception nil) (defvar ghc-keyword-Control.Monad nil) (defvar ghc-keyword-Data.Char nil) (defvar ghc-keyword-Data.List nil) (defvar ghc-keyword-Data.Maybe nil) (defvar ghc-keyword-System.IO nil) (defvar ghc-loaded-module nil) (defun ghc-comp-init () (let* ((syms '(ghc-module-names ghc-language-extensions ghc-option-flags ;; hard coded in GHCMod.hs ghc-keyword-Prelude ghc-keyword-Control.Applicative ghc-keyword-Control.Exception ghc-keyword-Control.Monad ghc-keyword-Data.Char ghc-keyword-Data.List ghc-keyword-Data.Maybe ghc-keyword-System.IO)) (vals (ghc-boot (length syms)))) (ghc-set syms vals)) (ghc-add ghc-module-names "qualified") (ghc-add ghc-module-names "hiding") ;; hard coded in GHCMod.hs (ghc-merge-keywords '("Prelude" "Control.Applicative" "Control.Exception" "Control.Monad" "Data.Char" "Data.List" "Data.Maybe" "System.IO"))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Executing command ;;; (defun ghc-boot (n) (prog2 (message "Initializing...") (ghc-sync-process "boot\n" n) (message "Initializing...done"))) (defun ghc-load-modules (mods) (if mods (mapcar 'ghc-load-module mods) (message "No new modules") nil)) (defun ghc-load-module (mod) (prog2 (message "Loading symbols for %s..." mod) (ghc-sync-process (format "browse %s\n" mod)) (message "Loading symbols for %s...done" mod))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Completion ;;; (defvar ghc-completion-buffer-name "*Completions*") (defun ghc-complete () (interactive) (if (ghc-should-scroll) (ghc-scroll-completion-buffer) (ghc-try-complete))) (defun ghc-should-scroll () (let ((window (ghc-completion-window))) (and (eq last-command this-command) window (window-live-p window) (window-buffer window) (buffer-name (window-buffer window))))) (defun ghc-scroll-completion-buffer () (let ((window (ghc-completion-window))) (with-current-buffer (window-buffer window) (if (pos-visible-in-window-p (point-max) window) (set-window-start window (point-min)) (save-selected-window (select-window window) (scroll-up)))))) (defun ghc-completion-window () (get-buffer-window ghc-completion-buffer-name 0)) (defun ghc-try-complete () (let* ((end (point)) (symbols (ghc-select-completion-symbol)) (beg (ghc-completion-start-point)) (pattern (buffer-substring-no-properties beg end)) (completion (try-completion pattern symbols))) (cond ((eq completion t) ;; completed ) ;; do nothing ((null completion) ;; no completions (ding)) ((not (string= pattern completion)) ;; ??? (delete-region beg end) (insert completion) (ghc-reset-window-configuration)) (t ;; multiple completions (let* ((list0 (all-completions pattern symbols)) (list (sort list0 'string<))) (if (= (length list) 1) (ghc-reset-window-configuration) (ghc-save-window-configuration) (with-output-to-temp-buffer ghc-completion-buffer-name (display-completion-list list)))))))) (defun ghc-save-window-configuration () (unless (get-buffer-window ghc-completion-buffer-name) (setq ghc-window-configuration (current-window-configuration)))) (defun ghc-reset-window-configuration () (when ghc-window-configuration (set-window-configuration ghc-window-configuration) (setq ghc-window-configuration nil))) (defun ghc-module-completion-p () (or (minibufferp) (let ((end (point))) (save-excursion (beginning-of-line) (and (looking-at "import ") (not (search-forward "(" end t))))) (save-excursion (beginning-of-line) (looking-at " +module ")))) (defun ghc-select-completion-symbol () (cond ((ghc-module-completion-p) ghc-module-names) ((save-excursion (beginning-of-line) (looking-at "{-# LANGUAGE ")) ghc-language-extensions) ((save-excursion (beginning-of-line) (looking-at "{-# OPTIONS_GHC ")) ghc-option-flags) ((save-excursion (beginning-of-line) (looking-at "{-# ")) ghc-pragma-names) ((or (bolp) (let ((end (point))) (save-excursion (beginning-of-line) (not (search-forward " " end t))))) ghc-reserved-keyword-for-bol) (t ghc-merged-keyword))) (defun ghc-completion-start-point () (save-excursion (let ((beg (save-excursion (beginning-of-line) (point))) (regex (if (ghc-module-completion-p) "[ (,`]" "[\[ (,`.]"))) (if (re-search-backward regex beg t) (1+ (point)) beg)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Loading keywords ;;; (defun ghc-import-module () (interactive) (ghc-load-module-buffer)) (defun ghc-unloaded-modules (mods) (ghc-filter (lambda (mod) (and (member mod ghc-module-names) (not (member mod ghc-loaded-module)))) mods)) (defun ghc-load-module-buffer () (ghc-load-merge-modules (ghc-gather-import-modules-buffer))) (defun ghc-load-merge-modules (mods) (let* ((umods (ghc-unloaded-modules mods)) (syms (mapcar 'ghc-module-symbol umods)) (names (ghc-load-modules umods))) (ghc-set syms names) (ghc-merge-keywords umods))) (defun ghc-merge-keywords (mods) (setq ghc-loaded-module (append mods ghc-loaded-module)) (let* ((modkeys (mapcar 'ghc-module-keyword ghc-loaded-module)) (keywords (cons ghc-extra-keywords (cons ghc-reserved-keyword modkeys))) (uniq-sorted (sort (ghc-uniq-lol keywords) 'string<))) (setq ghc-merged-keyword uniq-sorted))) (defun ghc-module-symbol (mod) (intern (concat ghc-keyword-prefix mod))) (defun ghc-module-keyword (mod) (symbol-value (ghc-module-symbol mod))) (defun ghc-gather-import-modules-buffer () (let (ret) (save-excursion (goto-char (point-min)) (while (re-search-forward "^import +\\(qualified\\)? *\\([^\n ]+\\)" nil t) (ghc-add ret (match-string-no-properties 2)) (forward-line))) ret)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Background Idle Timer ;;; (provide 'ghc-comp) ghc-mod-5.8.0.0/elisp/ghc-info.el0000644000000000000000000001021713112432356014517 0ustar0000000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ghc-info.el ;;; ;; Author: Kazu Yamamoto ;; Created: Nov 15, 2010 ;;; Code: (require 'ghc-func) (require 'ghc-process) (defun ghc-show-info (&optional ask) (interactive "P") (let* ((expr0 (ghc-things-at-point)) (expr (if (or ask (not expr0)) (ghc-read-expression expr0) expr0)) (info (ghc-get-info expr))) (when info (ghc-display nil (lambda () (insert info)))))) (defun ghc-get-info (expr) (let* ((file (buffer-file-name)) (cmd (format "info %s %s\n" file expr))) (ghc-sync-process cmd))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; type ;;; (defvar ghc-type-overlay nil) (make-variable-buffer-local 'ghc-type-overlay) (defun ghc-type-set-ix (n) (overlay-put ghc-type-overlay 'ix n)) (defun ghc-type-get-ix () (overlay-get ghc-type-overlay 'ix)) (defun ghc-type-set-point (pos) (overlay-put ghc-type-overlay 'pos pos)) (defun ghc-type-get-point () (overlay-get ghc-type-overlay 'pos)) (defun ghc-type-set-types (types) (overlay-put ghc-type-overlay 'types types)) (defun ghc-type-get-types () (overlay-get ghc-type-overlay 'types)) (ghc-defstruct tinfo beg-line beg-column end-line end-column info) (defun ghc-type-init () (setq ghc-type-overlay (make-overlay 0 0)) (overlay-put ghc-type-overlay 'face 'region) (ghc-type-clear-overlay) (setq after-change-functions (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) (when (overlayp ghc-type-overlay) (ghc-type-set-ix 0) (ghc-type-set-point 0) (move-overlay ghc-type-overlay 0 0))) (defun ghc-type-post-command-hook () (when (and (eq major-mode 'haskell-mode) (overlayp ghc-type-overlay) (/= (ghc-type-get-point) (point))) (ghc-type-clear-overlay))) (defun ghc-show-type () (interactive) (let ((buf (current-buffer)) (tinfos (ghc-type-get-tinfos))) (if (null tinfos) (progn (ghc-type-clear-overlay) (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)) (beg-column (ghc-tinfo-get-beg-column tinfo)) (end-line (ghc-tinfo-get-end-line tinfo)) (end-column (ghc-tinfo-get-end-column tinfo)) (left (ghc-get-pos buf beg-line beg-column)) (right (ghc-get-pos buf end-line end-column))) (move-overlay ghc-type-overlay (- left 1) (- right 1) buf) (message type))))) (defun ghc-type-get-tinfos () (if (= (ghc-type-get-point) (point)) (ghc-type-set-ix (mod (1+ (ghc-type-get-ix)) (length (ghc-type-get-types)))) (let ((types (ghc-type-obtain-tinfos))) (if (not (listp types)) ;; main does not exist in Main (ghc-type-set-types nil) (ghc-type-set-types types) (ghc-type-set-point (point)) (ghc-type-set-ix 0)))) (ghc-type-get-types)) (defun ghc-type-obtain-tinfos () (let* ((ln (int-to-string (line-number-at-pos))) (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))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Expanding Template Haskell ;;; (defun ghc-expand-th () (interactive) (let* ((file (buffer-file-name)) (cmds (list "-b" "\n" "expand" file)) (source (ghc-run-ghc-mod cmds))) (when source (ghc-display 'fontify (lambda () (insert source)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Misc ;;; (defun ghc-get-pos (buf line col) (save-excursion (set-buffer buf) (goto-char (point-min)) (forward-line (1- line)) (forward-char col) (point))) (defun ghc-read-expression (default) (if default (let ((prompt (format "Expression (%s): " default))) (read-string prompt default nil)) (read-string "Expression: "))) (defun ghc-find-module-name () (save-excursion (goto-char (point-min)) (if (re-search-forward "^module[ ]+\\([^ \n]+\\)" nil t) (match-string-no-properties 1)))) (provide 'ghc-info) ghc-mod-5.8.0.0/elisp/ghc-func.el0000644000000000000000000001775113112432356014531 0ustar0000000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ghc-func.el ;;; ;; Author: Kazu Yamamoto ;; Created: Sep 25, 2009 ;;; Code: (defvar ghc-module-command "ghc-mod" "*The command name of \"ghc-mod\"") (defvar ghc-ghc-options nil "*GHC options") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (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)) (if (char-equal (aref ret cnt) from) (aset ret cnt to))) ret)) (defun ghc-replace-character-buffer (from-c to-c) (let ((from (char-to-string from-c)) (to (char-to-string to-c))) (save-excursion (goto-char (point-min)) (while (search-forward from nil t) (replace-match to))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ghc-unescape-string (str) (with-temp-buffer (insert str) (goto-char (point-min)) (while (search-forward "\\n" nil t) (replace-match "\n" nil t)) (goto-char (point-min)) (while (search-forward "\\\\" nil t) (replace-match "\\" nil t)) (buffer-substring-no-properties (point-min) (point-max)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmacro ghc-add (sym val) `(setq ,sym (cons ,val ,sym))) (defun ghc-set (vars vals) (dolist (var vars) (if var (set var (car vals))) ;; var can be nil to skip (setq vals (cdr vals)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ghc-filter (pred lst) (let (ret) (dolist (x lst (reverse ret)) (if (funcall pred x) (ghc-add ret x))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ghc-uniq-lol (lol) (let ((hash (make-hash-table :test 'equal)) ret) (dolist (lst lol) (dolist (key lst) (puthash key key hash))) (maphash (lambda (key _val) (ghc-add ret key)) hash) ret)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ghc-read-lisp (func) (with-temp-buffer (funcall func) (ghc-read-lisp-this-buffer))) ;; OK/NG are ignored. (defun ghc-read-lisp-this-buffer () (save-excursion (goto-char (point-min)) (condition-case nil (read (current-buffer)) (error ())))) (defun ghc-read-lisp-list-this-buffer (n) (save-excursion (goto-char (point-min)) (condition-case nil (let ((m (set-marker (make-marker) 1 (current-buffer))) ret) (dotimes (_i n) (ghc-add ret (read m))) (nreverse ret)) (error ())))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ghc-mapconcat (func list) (apply 'append (mapcar func list))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ghc-things-at-point () (thing-at-point 'sexp)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ghc-keyword-number-pair (spec) (let ((len (length spec)) key ret) (dotimes (i len) (setq key (intern (concat ":" (symbol-name (car spec))))) (setq ret (cons (cons key i) ret)) (setq spec (cdr spec))) (nreverse ret))) (defmacro ghc-defstruct (type &rest spec) `(progn (ghc-defstruct-constructor ,type ,@spec) (ghc-defstruct-s/getter ,type ,@spec))) (defmacro ghc-defstruct-constructor (type &rest spec) `(defun ,(intern (concat "ghc-make-" (symbol-name type))) (&rest args) (let* ((alist (quote ,(ghc-keyword-number-pair spec))) (struct (make-list (length alist) nil)) key val key-num) (while args ;; cannot use dolist (setq key (car args)) (setq args (cdr args)) (setq val (car args)) (setq args (cdr args)) (unless (keywordp key) (error "'%s' is not a keyword" key)) (setq key-num (assoc key alist)) (if key-num (setcar (nthcdr (cdr key-num) struct) val) (error "'%s' is unknown" key))) struct))) (defmacro ghc-defstruct-s/getter (type &rest spec) `(let* ((type-name (symbol-name ',type)) (keys ',spec) (len (length keys)) member-name setter getter) (dotimes (i len) (setq member-name (symbol-name (car keys))) (setq setter (intern (format "ghc-%s-set-%s" type-name member-name))) (fset setter (list 'lambda '(struct value) (list 'setcar (list 'nthcdr i 'struct) 'value) 'struct)) (setq getter (intern (format "ghc-%s-get-%s" type-name member-name))) (fset getter (list 'lambda '(struct) (list 'nth i 'struct))) (setq keys (cdr keys))))) (defun ghc-make-ghc-options () (ghc-mapconcat (lambda (x) (list "-g" x)) ghc-ghc-options)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defconst ghc-error-buffer-name "*GHC Info*") (defun ghc-display (fontify ins-func) (ghc-display-with-name fontify ins-func ghc-error-buffer-name)) ;; (defun ghc-display (fontify ins-func) ;; (let ((buf ghc-error-buffer-name)) ;; (with-output-to-temp-buffer buf ;; (with-current-buffer buf ;; (erase-buffer) ;; (funcall ins-func) ;; (goto-char (point-min)) ;; (if (not fontify) ;; (turn-off-haskell-font-lock) ;; (haskell-font-lock-defaults-create) ;; (turn-on-haskell-font-lock))) ;; (display-buffer buf ;; '((display-buffer-reuse-window ;; display-buffer-pop-up-window)))))) (defun ghc-display-with-name (fontify ins-func name) (let ((buf name)) (with-output-to-temp-buffer buf (with-current-buffer buf (erase-buffer) (funcall ins-func) (goto-char (point-min)) (if (not fontify) ;; 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 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)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ghc-run-ghc-mod (cmds &optional prog) (let ((target (or prog ghc-module-command))) (ghc-executable-find target (let ((cdir (or ghc-process-root ;; ghc-mod version/debug default-directory))) ;; ghc-mod root (with-temp-buffer (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)) `(if (not (executable-find ,cmd)) (message "\"%s\" not found" ,cmd) ,@body)) (put 'ghc-executable-find 'lisp-indent-function 1) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar ghc-debug nil) (defvar ghc-debug-buffer "*GHC Debug*") (defmacro ghc-with-debug-buffer (&rest body) `(with-current-buffer (set-buffer (get-buffer-create ghc-debug-buffer)) (goto-char (point-max)) ,@body)) (defun ghc-call-process (cmd x y z &rest args) (apply 'call-process cmd x y z args) (when ghc-debug (let ((cbuf (current-buffer))) (ghc-with-debug-buffer (insert (format "%% %s %s\n" cmd (mapconcat 'identity args " "))) (insert-buffer-substring cbuf))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ghc-enclose (expr) (let ((case-fold-search nil)) (if (string-match "^[a-zA-Z0-9_]" expr) expr (concat "(" expr ")")))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmacro ghc-with-current-buffer (buf &rest body) ;; (declare (indent 1)) `(if (buffer-live-p ,buf) (with-current-buffer ,buf ,@body))) (provide 'ghc-func) ghc-mod-5.8.0.0/elisp/ghc-process.el0000644000000000000000000001633513112432356015251 0ustar0000000000000000;;; -*- lexical-binding: t -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ghc-process.el ;;; ;; Author: Kazu Yamamoto ;; Created: Mar 9, 2014 ;;; Code: (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-root nil) (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 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 sync-before-hook (funcall sync-before-hook)) (let* ((cbuf (current-buffer)) (name ghc-process-process-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-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 root) (cond ((not cpro) (ghc-start-process name buf root)) ((not (eq (process-status cpro) 'run)) (delete-process cpro) (ghc-start-process name buf root)) (t cpro))) (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)) (tbufname (concat " tmp " (buffer-name pbuf))) tbuf) (if (not (get-buffer pbuf)) (setq ghc-process-running nil) ;; just in case (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$") (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-async-after-callback 'ng) (setq ghc-process-running nil))))))) (defun ghc-process-sentinel (_process _event) (setq ghc-process-running nil) (setq ghc-process-file-mapping nil)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defvar ghc-process-rendezvous nil) (defvar ghc-process-num-of-results nil) (defvar ghc-process-results nil) (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-sync-process-callback nil))) ;; ghc-process-running is now t. ;; But if the process exits abnormally, it is set to nil. (condition-case nil (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-sync-process-callback (status) (cond ((eq status 'ok) (let* ((n ghc-process-num-of-results) (ret (if (= n 1) (ghc-read-lisp-this-buffer) (ghc-read-lisp-list-this-buffer n)))) (setq ghc-process-results ret))) (t (setq ghc-process-results nil))) (setq ghc-process-num-of-results nil) (setq ghc-process-rendezvous t)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ghc-kill-process () (interactive) (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) ghc-mod-5.8.0.0/elisp/ghc.el0000644000000000000000000001334313112432356013571 0ustar0000000000000000;;; ghc.el --- ghc-mod front-end for haskell-mode ;; Author: Kazu Yamamoto ;; Created: Sep 25, 2009 ;; Revised: ;; Put the following code to your "~/.emacs". ;; ;; (autoload 'ghc-init "ghc" nil t) ;; (autoload 'ghc-debug "ghc" nil t) ;; (add-hook 'haskell-mode-hook (lambda () (ghc-init))) ;; ;; Or if you wish to display error each goto next/prev error, ;; set ghc-display-error valiable. ;; ;; (setq ghc-display-error 'minibuffer) ; to minibuffer ;; ; (setq ghc-display-error 'other-buffer) ; to other-buffer ;; ;;; Code: ;; defvar-local was introduced in 24.3 (let* ((major 24) (minor 3)) (if (or (< emacs-major-version major) (and (= emacs-major-version major) (< emacs-minor-version minor))) (error "ghc-mod requires at least Emacs %d.%d" major minor))) (defconst ghc-version "5.8.0.0") (defgroup ghc-mod '() "ghc-mod customization") ;; (eval-when-compile ;; (require 'haskell-mode)) (require 'ghc-comp) (require 'ghc-doc) (require 'ghc-info) (require 'ghc-check) (require 'ghc-command) (require 'ghc-ins-mod) (require 'ghc-indent) (require 'ghc-rewrite) (require 'dabbrev) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Customize Variables ;;; (defun ghc-find-C-h () (or (when keyboard-translate-table (aref keyboard-translate-table ?\C-h)) ?\C-h)) (defvar ghc-completion-key "\e\t") (defvar ghc-document-key "\e\C-d") (defvar ghc-import-key "\e\C-m") (defvar ghc-previous-key "\ep") (defvar ghc-next-key "\en") (defvar ghc-help-key "\e?") (defvar ghc-insert-key "\et") (defvar ghc-sort-key "\es") (defvar ghc-type-key "\C-c\C-t") (defvar ghc-info-key "\C-c\C-i") (defvar ghc-toggle-key "\C-c\C-c") (defvar ghc-jump-key "\C-c\C-j") (defvar ghc-module-key "\C-c\C-m") (defvar ghc-expand-key "\C-c\C-e") (defvar ghc-kill-key "\C-c\C-k") (defvar ghc-hoogle-key (format "\C-c%c" (ghc-find-C-h))) (defvar ghc-shallower-key "\C-c<") (defvar ghc-deeper-key "\C-c>") ;(defvar ghc-case-split-key "\C-c\C-s") (defvar ghc-refine-key "\C-c\C-f") (defvar ghc-auto-key "\C-c\C-a") (defvar ghc-prev-hole-key "\C-c\ep") (defvar ghc-next-hole-key "\C-c\en") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Initializer ;;; (defvar ghc-initialized nil) ;;;###autoload (defun ghc-init () (ghc-abbrev-init) (ghc-type-init) (unless ghc-initialized (define-key haskell-mode-map ghc-completion-key 'ghc-complete) (define-key haskell-mode-map ghc-document-key 'ghc-browse-document) (define-key haskell-mode-map ghc-type-key 'ghc-show-type) (define-key haskell-mode-map ghc-info-key 'ghc-show-info) (define-key haskell-mode-map ghc-expand-key 'ghc-expand-th) (define-key haskell-mode-map ghc-import-key 'ghc-import-module) (define-key haskell-mode-map ghc-previous-key 'ghc-goto-prev-error) (define-key haskell-mode-map ghc-next-key 'ghc-goto-next-error) (define-key haskell-mode-map ghc-help-key 'ghc-display-errors) (define-key haskell-mode-map ghc-insert-key 'ghc-insert-template-or-signature) (define-key haskell-mode-map ghc-sort-key 'ghc-sort-lines) (define-key haskell-mode-map ghc-toggle-key 'ghc-toggle-check-command) (define-key haskell-mode-map ghc-jump-key 'ghc-jump-file) (define-key haskell-mode-map ghc-module-key 'ghc-insert-module) (define-key haskell-mode-map ghc-kill-key 'ghc-kill-process) (define-key haskell-mode-map ghc-hoogle-key 'haskell-hoogle) (define-key haskell-mode-map ghc-shallower-key 'ghc-make-indent-shallower) (define-key haskell-mode-map ghc-deeper-key 'ghc-make-indent-deeper) ;(define-key haskell-mode-map ghc-case-split-key 'ghc-case-split) (define-key haskell-mode-map ghc-refine-key 'ghc-refine) (define-key haskell-mode-map ghc-auto-key 'ghc-auto) (define-key haskell-mode-map ghc-prev-hole-key 'ghc-goto-prev-hole) (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)))) (ghc-import-module) (ghc-check-syntax)) (defun ghc-abbrev-init () (set (make-local-variable 'dabbrev-case-fold-search) nil)) ;;;###autoload (defun ghc-debug () (interactive) (let ((el-path (locate-file "ghc.el" load-path)) (ghc-path (executable-find "ghc")) ;; FIXME (ghc-mod-path (executable-find ghc-module-command)) (el-ver ghc-version) (ghc-ver (ghc-run-ghc-mod '("--version") "ghc")) (ghc-mod-ver (ghc-run-ghc-mod '("version"))) (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 "\t ghc path: %s\n" ghc-path)) (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-ver)) (insert "\nEnvironment variables:\n") (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") (if flag (ghc-initial-code-from-signature) (ghc-insert-template))) (provide 'ghc)