ghc-mod-5.4.0.0/0000755000000000000000000000000012576164335011376 5ustar0000000000000000ghc-mod-5.4.0.0/Utils.hs0000644000000000000000000000154012576164335013032 0ustar0000000000000000{-# LANGUAGE CPP #-} module Utils where import Control.Applicative import Data.Traversable import System.Directory #if MIN_VERSION_directory(1,2,0) import Data.Time (UTCTime) #else import System.Time (ClockTime) #endif import Prelude #if MIN_VERSION_directory(1,2,0) type ModTime = UTCTime #else type ModTime = ClockTime #endif data TimedFile = TimedFile { tfPath :: FilePath, tfTime :: ModTime } deriving (Eq, Show) instance Ord TimedFile where compare (TimedFile _ a) (TimedFile _ b) = compare a b timeFile :: FilePath -> IO TimedFile timeFile f = TimedFile <$> pure f <*> getModificationTime f mightExist :: FilePath -> IO (Maybe FilePath) mightExist f = do exists <- doesFileExist f return $ if exists then (Just f) else (Nothing) timeMaybe :: FilePath -> IO (Maybe TimedFile) timeMaybe f = traverse timeFile =<< mightExist f ghc-mod-5.4.0.0/LICENSE0000644000000000000000000000053212576164335012403 0ustar0000000000000000ghc-mod was originally licensed under the BSD3 but the primary license has been changed to the AGPL3, files originally contributed under the BSD3 license remain under this license and can generally be identified by the lack of a GPL header. See the files COPYING.BSD3 and COPYING.AGPL3 in the source distribution for copies of the two licenses. ghc-mod-5.4.0.0/COPYING.BSD30000644000000000000000000000276512576164335013135 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.4.0.0/COPYING.AGPL30000644000000000000000000010333012576164335013236 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.4.0.0/Setup.hs0000644000000000000000000001543512576164335013042 0ustar0000000000000000#!/usr/bin/env runhaskell {-# LANGUAGE RecordWildCards #-} import Distribution.Simple import Distribution.Simple.Setup import Distribution.Simple.Install import Distribution.Simple.Register import Distribution.Simple.InstallDirs as ID import Distribution.Simple.LocalBuildInfo import Distribution.PackageDescription import Control.Arrow import Control.Applicative import Control.Monad import Data.List import Data.Maybe import Data.Version import Data.Monoid import System.Process import System.Exit import System.FilePath import Text.ParserCombinators.ReadP import SetupCompat main :: IO () main = defaultMainWithHooks $ simpleUserHooks { confHook = \(gpd, hbi) cf -> xBuildDependsLike <$> (confHook simpleUserHooks) (gpd, hbi) cf , instHook = inst , copyHook = copy -- , postConf = sanityCheckCabalVersions } xBuildDependsLike :: LocalBuildInfo -> LocalBuildInfo xBuildDependsLike lbi = let cc = componentsConfigs lbi pd = localPkgDescr lbi deps = dependsMap lbi in setComponentsConfigs lbi [ (cn, updateClbi deps comp clbi, cdeps) | (cn, clbi, cdeps) <- cc , let comp = getComponent pd cn ] where updateClbi deps comp clbi = setUnionDeps (otherDeps deps comp) clbi dependsMap :: LocalBuildInfo -> [(ComponentName, Deps)] dependsMap lbi = second getDeps <$> allComponentsInBuildOrder lbi otherDeps :: [(ComponentName, Deps)] -> Component -> Deps otherDeps deps comp = fromMaybe noDeps $ flip lookup deps =<< read <$> lookup "x-build-depends-like" fields where fields = customFieldsBI (componentBuildInfo comp) -- mostly copypasta from 'defaultInstallHook' inst :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO () inst pd lbi _uf ifl = do let copyFlags = defaultCopyFlags { copyDistPref = installDistPref ifl, copyDest = toFlag NoCopyDest, copyVerbosity = installVerbosity ifl } xInstallTarget pd lbi (\pd' lbi' -> install pd' lbi' copyFlags) let registerFlags = defaultRegisterFlags { regDistPref = installDistPref ifl, regInPlace = installInPlace ifl, regPackageDB = installPackageDB ifl, regVerbosity = installVerbosity ifl } when (hasLibs pd) $ register pd lbi registerFlags copy :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO () copy pd lbi _uh cf = xInstallTarget pd lbi (\pd' lbi' -> install pd' lbi' cf) xInstallTarget :: PackageDescription -> LocalBuildInfo -> (PackageDescription -> LocalBuildInfo -> IO ()) -> IO () xInstallTarget pd lbi fn = do let (extended, regular) = partition (isJust . installTarget) (executables pd) let pd_regular = pd { executables = regular } _ <- flip mapM extended $ \exe -> do putStrLn $ "extended " ++ show (exeName exe) let idirtpl = installDirTemplates lbi env = installDirsTemplateEnv idirtpl libexecdir' = fromPathTemplate (libexecdir idirtpl) pd_extended = onlyExePackageDesc [exe] pd install_target = fromJust $ installTarget exe install_target' = ID.substPathTemplate env install_target -- $libexec isn't a real thing :/ so we have to simulate it install_target'' = substLibExec' libexecdir' install_target' let lbi' = lbi { installDirTemplates = (installDirTemplates lbi) { bindir = install_target'' } } fn pd_extended lbi' fn pd_regular lbi where installTarget :: Executable -> Maybe PathTemplate installTarget exe = toPathTemplate <$> lookup "x-install-target" (customFieldsBI $ buildInfo exe) substLibExec libexecdir "$libexecdir" = libexecdir substLibExec _ comp = comp substLibExec' dir = withPT $ withSP $ map (substLibExec dir . dropTrailingPathSeparator) withPT f pt = toPathTemplate $ f (fromPathTemplate pt) withSP f p = joinPath $ f (splitPath p) onlyExePackageDesc :: [Executable] -> PackageDescription -> PackageDescription onlyExePackageDesc exes pd = emptyPackageDescription { package = package pd , executables = exes } parseVer str = case filter ((=="") . snd) $ readP_to_S parseVersion str of [(ver, _)] -> ver _ -> error $ "No parse (Ver) :(\n" ++ str ++ "\n" -- sanityCheckCabalVersions args cf desc lbi = do -- (cabalInstallVer, cabalVer) <- getCabalExecVer -- let -- ghcVer = compilerVersion (compiler lbi) -- -- ghc >= 7.10? -- minGhc710 = ghcVer `withinRange` orLaterVersion (parseVer "7.10") -- when minGhc710 $ do -- let cabalHelperCabalVer = compCabalVer (CExeName "cabal-helper") -- when (not $ cabalVer `sameMajorVersionAs` cabalHelperCabalVer) $ -- failCabalVersionDifferent cabalVer cabalHelperCabalVer -- -- carry on as usual -- (postConf simpleUserHooks) args cf desc lbi -- where -- earlierVersionThan ver ver' = -- ver `withinRange` earlierVersion ver' -- sameMajorVersionAs ver ver' = -- ver `withinRange` withinVersion (Version (take 2 $ versionBranch ver') []) -- compCabalVer comp = let -- clbi = getComponentLocalBuildInfo lbi comp -- [cabalVer] = -- [ ver | (_, PackageIdentifier pkg ver) <- componentPackageDeps clbi -- , pkg == PackageName "Cabal" ] -- in cabalVer -- getCabalExecVer = do -- ["cabal-install", "version", cabalInstallVer, "using", "version", cabalVer, "of", "the", "Cabal", "library"] <- words <$> readProcess "cabal" ["--version"] "" -- return (parseVer cabalInstallVer, parseVer cabalVer) -- failCabalVersionDifferent cabalVer libCabalVer = -- putStrLn rerr >> exitFailure -- where -- replace :: String -> String -> String -> String -- replace _ _ [] = [] -- replace n r h@(h':hs) -- | map snd (n `zip` h ) == n = r ++ replace n r (drop (length n) h) -- | otherwise = h':replace n r hs -- rerr = replace "X.XX.X.X" (showVersion libCabalVer) $ -- replace "Y.YY.Y.Y" (showVersion cabalVer) err -- err = "\ -- \Error: Cabal seems to have decided ghc-mod should be built using Cabal\n\ -- \X.XX.X.X while the `cabal' executable in your PATH was built with Cabal\n\ -- \Y.YY.Y.Y. This will lead to conflicts when running ghc-mod in any project\n\ -- \where you use this `cabal' executable. Please compile ghc-mod using the same\n\ -- \Cabal version as your `cabal' executable or recompile cabal-install using\n\ -- \this version of the Cabal library.\n\ -- \\n\ -- \See: https://github.com/kazu-yamamoto/ghc-mod/wiki/InconsistentCabalVersions\n" ghc-mod-5.4.0.0/ghc-mod.cabal0000644000000000000000000003072612576164335013710 0ustar0000000000000000Name: ghc-mod Version: 5.4.0.0 Author: Kazu Yamamoto , Daniel Gröber , Alejandro Serrano Maintainer: Daniel Gröber License: AGPL-3 License-File: LICENSE License-Files: COPYING.BSD3 COPYING.AGPL3 Homepage: http://www.mew.org/~kazu/proj/ghc-mod/ Synopsis: Happy Haskell Programming Description: 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. For more information, please see its home page. Category: GHC, Development Cabal-Version: >= 1.14 Build-Type: Custom Data-Files: elisp/Makefile elisp/*.el Data-Files: LICENSE COPYING.BSD3 COPYING.AGPL3 Extra-Source-Files: ChangeLog SetupCompat.hs NotCPP/*.hs NotCPP/COPYING test/data/annotations/*.hs test/data/broken-cabal/*.cabal test/data/broken-cabal/cabal.sandbox.config.in test/data/broken-sandbox/cabal.sandbox.config test/data/broken-sandbox/dummy.cabal test/data/cabal-flags/cabal-flags.cabal test/data/cabal-project/*.cabal test/data/cabal-project/*.hs test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf test/data/cabal-project/cabal.sandbox.config.in test/data/cabal-project/subdir1/subdir2/dummy test/data/case-split/*.hs test/data/check-packageid/cabal.sandbox.config.in test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf test/data/check-test-subdir/*.cabal test/data/check-test-subdir/src/Check/Test/*.hs test/data/check-test-subdir/test/*.hs test/data/check-test-subdir/test/Bar/*.hs test/data/duplicate-pkgver/cabal.sandbox.config.in test/data/duplicate-pkgver/duplicate-pkgver.cabal test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-1.0-7c59d13f32294d1ef6dc6233c24df961.conf test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-14e543bdae2da4d2aeff5386892c9112.conf test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf test/data/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 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 Library Default-Language: Haskell2010 GHC-Options: -Wall -fno-warn-deprecations Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns, ConstraintKinds, FlexibleContexts, DataKinds, KindSignatures, TypeOperators, ViewPatterns Exposed-Modules: Language.Haskell.GhcMod Language.Haskell.GhcMod.Internal Language.Haskell.GhcMod.Boot Language.Haskell.GhcMod.Browse Language.Haskell.GhcMod.CabalHelper Language.Haskell.GhcMod.Caching Language.Haskell.GhcMod.Caching.Types Language.Haskell.GhcMod.CaseSplit Language.Haskell.GhcMod.Check Language.Haskell.GhcMod.Convert Language.Haskell.GhcMod.Cradle Language.Haskell.GhcMod.CustomPackageDb Language.Haskell.GhcMod.Debug Language.Haskell.GhcMod.DebugLogger Language.Haskell.GhcMod.Doc Language.Haskell.GhcMod.DynFlags Language.Haskell.GhcMod.Error Language.Haskell.GhcMod.FileMapping Language.Haskell.GhcMod.FillSig Language.Haskell.GhcMod.Find Language.Haskell.GhcMod.Flag Language.Haskell.GhcMod.Gap Language.Haskell.GhcMod.GhcPkg Language.Haskell.GhcMod.HomeModuleGraph Language.Haskell.GhcMod.Info Language.Haskell.GhcMod.Lang Language.Haskell.GhcMod.Lint Language.Haskell.GhcMod.LightGhc Language.Haskell.GhcMod.Logger Language.Haskell.GhcMod.Logging Language.Haskell.GhcMod.Modules Language.Haskell.GhcMod.Monad Language.Haskell.GhcMod.Monad.Types Language.Haskell.GhcMod.Output Language.Haskell.GhcMod.PathsAndFiles Language.Haskell.GhcMod.PkgDoc Language.Haskell.GhcMod.Pretty Language.Haskell.GhcMod.Read Language.Haskell.GhcMod.SrcUtils Language.Haskell.GhcMod.Stack Language.Haskell.GhcMod.Target Language.Haskell.GhcMod.Types Language.Haskell.GhcMod.Utils Language.Haskell.GhcMod.World Other-Modules: Paths_ghc_mod Utils Build-Depends: base >= 4.0 && < 5 , bytestring , cereal >= 0.4 , containers , cabal-helper == 0.6.* && >= 0.6.0.0 , deepseq , directory , filepath , ghc , ghc-paths , ghc-syb-utils , hlint >= 1.8.61 , monad-journal >= 0.4 , old-time , pretty , process , syb , temporary , time , transformers , transformers-base , mtl >= 2.0 , monad-control >= 1 , split , haskell-src-exts , text , djinn-ghc >= 0.0.2.2 , fclabels == 2.0.* , extra == 1.4.* , pipes == 4.1.* if impl(ghc < 7.8) Build-Depends: convertible if impl(ghc < 7.5) -- Only used to constrain random to a version that still works with GHC 7.4 Build-Depends: random <= 1.0.1.1, ghc-prim Executable ghc-mod Default-Language: Haskell2010 Main-Is: GHCMod.hs Other-Modules: Paths_ghc_mod GHC-Options: -Wall -fno-warn-deprecations -threaded Default-Extensions: ConstraintKinds, FlexibleContexts HS-Source-Dirs: src Build-Depends: base >= 4.0 && < 5 , async , directory , filepath , pretty , process , split , mtl >= 2.0 , ghc , ghc-mod , fclabels == 2.0.* Executable ghc-modi Default-Language: Haskell2010 Main-Is: GHCModi.hs Other-Modules: Paths_ghc_mod Misc Utils GHC-Options: -Wall -threaded -fno-warn-deprecations if os(windows) Cpp-Options: -DWINDOWS Default-Extensions: ConstraintKinds, FlexibleContexts HS-Source-Dirs: src, . Build-Depends: base >= 4.0 && < 5 , directory , filepath , process , time , old-time 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 if impl(ghc == 7.4.*) Buildable: False Build-Depends: base , doctest >= 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, . Ghc-Options: -Wall -fno-warn-deprecations CPP-Options: -DSPEC=1 Type: exitcode-stdio-1.0 Other-Modules: Paths_ghc_mod Dir Spec TestUtils BrowseSpec CustomPackageDbSpec CheckSpec FlagSpec InfoSpec LangSpec LintSpec ListSpec MonadSpec PathsAndFilesSpec HomeModuleGraphSpec FileMappingSpec Build-Depends: hspec >= 2.0.0 if impl(ghc == 7.4.*) Build-Depends: executable-path X-Build-Depends-Like: CLibName Source-Repository head Type: git Location: https://github.com/kazu-yamamoto/ghc-mod.git ghc-mod-5.4.0.0/ChangeLog0000644000000000000000000002125412576164335013154 0ustar00000000000000002015-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.4.0.0/SetupCompat.hs0000644000000000000000000001443212576164335014202 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, RecordWildCards, StandaloneDeriving #-} module SetupCompat where import Control.Arrow import Control.Monad.Trans.State import Data.List import Data.Maybe import Data.Functor import Data.Function import Distribution.Simple.LocalBuildInfo import Distribution.PackageDescription import Distribution.Simple import Distribution.Simple.Setup import Distribution.Simple.Install import qualified Data.Map as M import Data.Map (Map) import NotCPP.Declarations import Language.Haskell.TH -- $(ifdefD "componentsConfigs" [d| deriving instance (Ord ComponentName) |] ) $(ifD [d| showComponentName :: ComponentName -> String showComponentName CLibName = "library" showComponentName (CExeName name) = "executable '" ++ name ++ "'" showComponentName (CTestName name) = "test suite '" ++ name ++ "'" showComponentName (CBenchName name) = "benchmark '" ++ name ++ "'" |]) $(ifelsedefD "componentsConfigs" [d| setComponentsConfigs :: LocalBuildInfo -> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])] -> LocalBuildInfo setComponentsConfigs lbi cs = $(recUpdE' (nE "lbi") (mkName "componentsConfigs") (VarE $ mkName "cs")) |] [d| setComponentsConfigs :: LocalBuildInfo -> [(ComponentName, ComponentLocalBuildInfo, a)] -> LocalBuildInfo setComponentsConfigs lbi cs = flip execState lbi $ mapM setClbis gcs where gcs = groupBy (sameKind `on` fst3) $ sortBy (compare `on` showComponentName . fst3) cs fst3 (x,_,_) = x sameKind CLibName CLibName = True sameKind CLibName _ = False sameKind (CExeName _) (CExeName _) = True sameKind (CExeName _) _ = False sameKind (CTestName _) (CTestName _) = True sameKind (CTestName _) _ = False sameKind (CBenchName _) (CBenchName _) = True sameKind (CBenchName _) _ = False setClbis [(CLibName, clbi, _)] = get >>= \lbi -> put $ $(recUpdE' (nE "lbi") (mkName "libraryConfig") (AppE (ConE (mkName "Just")) (VarE (mkName "clbi")))) setClbis cs@((CExeName _, _, _):_) = let cfg = (\((CExeName n), clbi, _) -> (n, clbi)) <$> cs in get >>= \lbi -> put $ $(recUpdE' (nE "lbi") (mkName "executableConfigs") (VarE $ mkName "cfg")) setClbis cs@((CTestName _, _, _):_) = let cfg = (\((CTestName n), clbi, _) -> (n, clbi)) <$> cs in get >>= \lbi -> put $ $(recUpdE' (nE "lbi") (mkName "testSuiteConfigs") (VarE $ mkName "cfg")) setClbis cs@((CBenchName _, _, _):_) = let cfg = (\((CBenchName n), clbi, _) -> (n, clbi)) <$> cs in get >>= \lbi -> put $ $(recUpdE' (nE "lbi") (mkName "benchmarkConfigs") (VarE $ mkName "cfg")) |]) $(ifD [d| componentsConfigs :: LocalBuildInfo -> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])] componentsConfigs LocalBuildInfo {..} = (maybe [] (\c -> [(CLibName, c, [])]) $(nE "libraryConfig")) ++ ((\(n, clbi) -> (CExeName n, clbi, [])) <$> $(nE "executableConfigs")) ++ ((\(n, clbi) -> (CTestName n, clbi, [])) <$> $(nE "testSuiteConfigs")) ++ ((\(n, clbi) -> (CBenchName n, clbi, [])) <$> $(nE "benchmarkConfigs")) getComponent :: PackageDescription -> ComponentName -> Component getComponent pkg cname = case lookupComponent pkg cname of Just cpnt -> cpnt Nothing -> missingComponent where missingComponent = error $ "internal error: the package description contains no " ++ "component corresponding to " ++ show cname lookupComponent :: PackageDescription -> ComponentName -> Maybe Component lookupComponent pkg CLibName = fmap CLib $ library pkg lookupComponent pkg (CExeName name) = fmap CExe $ find ((name ==) . exeName) (executables pkg) lookupComponent pkg (CTestName name) = fmap CTest $ find ((name ==) . testName) (testSuites pkg) lookupComponent pkg (CBenchName name) = fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg) -- We're lying here can't be bothered to order these allComponentsInBuildOrder :: LocalBuildInfo -> [(ComponentName, ComponentLocalBuildInfo)] allComponentsInBuildOrder lbi = [ (cname, clbi) | (cname, clbi, _) <- componentsConfigs lbi ] getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo getComponentLocalBuildInfo lbi cname = case [ clbi | (cname', clbi, _) <- componentsConfigs lbi , cname == cname' ] of [clbi] -> clbi _ -> missingComponent where missingComponent = error $ "internal error: there is no configuration data " ++ "for component " ++ show cname componentBuildInfo :: Component -> BuildInfo componentBuildInfo = foldComponent libBuildInfo buildInfo testBuildInfo benchmarkBuildInfo |]) $(ifelsedefD "componentPackageRenaming" [d| -- M.Map PackageName newtype Deps = Deps { unDeps :: ([(InstalledPackageId, PackageId)], Map PackageName $(cT "ModuleRenaming")) } -- $(return $ TySynD $(mkName "Deps") [] [t| |] ) noDeps = Deps ([], M.empty) getDeps :: ComponentLocalBuildInfo -> Deps getDeps = componentPackageDeps &&& $(nE "componentPackageRenaming") >>> Deps setUnionDeps :: Deps -> ComponentLocalBuildInfo -> ComponentLocalBuildInfo setUnionDeps (Deps (deps, rns)) clbi = let clbi' = setComponentPackageRenaming clbi rns cpdeps = componentPackageDeps clbi in clbi' { componentPackageDeps = cpdeps `union` deps } setComponentPackageRenaming clbi cprn = -- [| clbi { componentPackageRenaming = componentPackageRenaming clbi `M.union` cprn } |] $(recUpdE' (nE "clbi") (mkName "componentPackageRenaming") (InfixE (Just (AppE (VarE (mkName "componentPackageRenaming")) (VarE (mkName "clbi")) )) (VarE (mkName "M.union")) (Just (VarE (mkName "cprn"))) ) ) |] [d| newtype Deps = Deps { unDeps :: [(InstalledPackageId, PackageId)] } noDeps = Deps [] getDeps :: ComponentLocalBuildInfo -> Deps getDeps lbi = Deps $ componentPackageDeps lbi setUnionDeps :: Deps -> ComponentLocalBuildInfo -> ComponentLocalBuildInfo setUnionDeps (Deps deps) clbi = let cpdeps = componentPackageDeps clbi in clbi { componentPackageDeps = cpdeps `union` deps } -- setComponentPackageRenaming clbi _cprn = clbi |]) ghc-mod-5.4.0.0/Language/0000755000000000000000000000000012576164335013121 5ustar0000000000000000ghc-mod-5.4.0.0/Language/Haskell/0000755000000000000000000000000012576164335014504 5ustar0000000000000000ghc-mod-5.4.0.0/Language/Haskell/GhcMod.hs0000644000000000000000000000342612576164335016206 0ustar0000000000000000-- | The ghc-mod library. module Language.Haskell.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 , splits , sig , refine , auto , modules , languages , flags , findSymbol , lookupSymbol , dumpSymbol -- * SymbolDb , loadSymbolDb , isOutdated -- * Output , gmPutStr , gmErrStr , gmPutStrLn , gmErrStrLn -- * FileMapping , loadMappedFile , loadMappedFileSource , unloadMappedFile ) where import Language.Haskell.GhcMod.Boot import Language.Haskell.GhcMod.Browse import Language.Haskell.GhcMod.CaseSplit import Language.Haskell.GhcMod.Check import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.Debug import Language.Haskell.GhcMod.FillSig import Language.Haskell.GhcMod.Find import Language.Haskell.GhcMod.Flag import Language.Haskell.GhcMod.Info import Language.Haskell.GhcMod.Lang import Language.Haskell.GhcMod.Lint import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Modules import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.PkgDoc import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Target import Language.Haskell.GhcMod.Output import Language.Haskell.GhcMod.FileMapping ghc-mod-5.4.0.0/Language/Haskell/GhcMod/0000755000000000000000000000000012576164335015645 5ustar0000000000000000ghc-mod-5.4.0.0/Language/Haskell/GhcMod/Internal.hs0000644000000000000000000000330612576164335017757 0ustar0000000000000000-- | Low level access to the ghc-mod library. module Language.Haskell.GhcMod.Internal ( -- * Types GHCOption , Package , PackageBaseName , PackageVersion , PackageId , IncludeDir , GmlT(..) , MonadIO(..) , GmEnv(..) -- * Various Paths , ghcLibDir , ghcModExecutable -- * Logging , withLogger , setNoWarningFlags , setAllWarningFlags -- * Environment, state and logging , GhcModEnv(..) , GhcModState , CompilerMode(..) , GhcModLog , GmLog(..) , GmLogLevel(..) , gmSetLogLevel -- * Monad utilities , runGhcModT' , hoistGhcModT , runGmlT , runGmlT' , gmlGetSession , gmlSetSession , loadTargets , cabalResolvedComponents -- ** Accessing 'GhcModEnv' and 'GhcModState' , options , cradle , getCompilerMode , setCompilerMode , targetGhcOptions , withOptions -- * 'GhcModError' , gmeDoc -- * World , World , getCurrentWorld , didWorldChange -- * Cabal Helper , ModulePath(..) , GmComponent(..) , GmComponentType(..) , GmModuleGraph(..) , prepareCabalHelper -- * Misc stuff , GHandler(..) , gcatches -- * FileMapping , module Language.Haskell.GhcMod.FileMapping ) where import GHC.Paths (libdir) import Language.Haskell.GhcMod.Target import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Logger import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.World import Language.Haskell.GhcMod.CabalHelper import Language.Haskell.GhcMod.FileMapping -- | Obtaining the directory for ghc system libraries. ghcLibDir :: FilePath ghcLibDir = libdir ghc-mod-5.4.0.0/Language/Haskell/GhcMod/Boot.hs0000644000000000000000000000126212576164335017105 0ustar0000000000000000module Language.Haskell.GhcMod.Boot where import Control.Applicative import Prelude import Language.Haskell.GhcMod.Browse import Language.Haskell.GhcMod.Flag import Language.Haskell.GhcMod.Lang import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Modules -- | Printing necessary information for front-end booting. boot :: IOish m => GhcModT m String boot = concat <$> sequence ms where ms = [modules, languages, flags, concat <$> mapM browse preBrowsedModules] preBrowsedModules :: [String] preBrowsedModules = [ "Prelude" , "Control.Applicative" , "Control.Exception" , "Control.Monad" , "Data.Char" , "Data.List" , "Data.Maybe" , "System.IO" ] ghc-mod-5.4.0.0/Language/Haskell/GhcMod/Browse.hs0000644000000000000000000001205412576164335017444 0ustar0000000000000000module Language.Haskell.GhcMod.Browse ( browse ) where import Control.Applicative import Control.Exception (SomeException(..)) import Data.Char import Data.List import Data.Maybe import FastString import GHC import qualified GHC as G import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Doc (showPage, styleUnqualified) import Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types import Name (getOccString) import Outputable import TyCon (isAlgTyCon) import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy) import Exception (ExceptionMonad, ghandle) import Prelude ---------------------------------------------------------------- -- | Getting functions, classes, etc from a module. -- If 'detailed' is 'True', their types are also obtained. -- If 'operators' is 'True', operators are also returned. browse :: forall m. IOish m => String -- ^ A module name. (e.g. \"Data.List\", "base:Prelude") -> GhcModT m String browse 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 (\(SomeException _) -> return []) $ do goPkgModule `G.gcatch` (\(SomeException _) -> goHomeModule) goPkgModule = do opt <- options runGmPkgGhc $ processExports opt =<< tryModuleInfo =<< G.findModule mdlname mpkgid goHomeModule = runGmlT [Right mdlname] $ do opt <- options processExports opt =<< tryModuleInfo =<< G.findModule mdlname Nothing tryModuleInfo m = fromJust <$> G.getModuleInfo m (mpkg, mdl) = splitPkgMdl pkgmdl mdlname = G.mkModuleName mdl mpkgid = mkFastString <$> mpkg -- | -- -- >>> 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) => Options -> ModuleInfo -> m [String] processExports opt minfo = do let removeOps | optOperators opt = id | otherwise = filter (isNotOp . getOccString) mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo showExport :: forall m. (G.GhcMonad m, MonadIO m, ExceptionMonad m) => Options -> ModuleInfo -> Name -> m String showExport opt minfo e = do mtype' <- mtype return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype'] where mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` optQualified opt mtype :: m (Maybe String) mtype | optDetailed opt = do tyInfo <- G.modInfoLookupName minfo e -- If nothing found, load dependent module and lookup global tyResult <- maybe (inOtherModule e) (return . Just) tyInfo dflag <- G.getSessionDynFlags return $ do typeName <- tyResult >>= showThing dflag (" :: " ++ typeName) `justIf` optDetailed opt | 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) 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.4.0.0/Language/Haskell/GhcMod/CabalHelper.hs0000644000000000000000000002455712576164335020360 0ustar0000000000000000-- ghc-mod: Making Haskell development *more* fun -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE CPP #-} module Language.Haskell.GhcMod.CabalHelper #ifndef SPEC ( getComponents , getGhcMergedPkgOptions , getCabalPackageDbStack , prepareCabalHelper ) #endif where import Control.Applicative import Control.Monad import Control.Category ((.)) import Data.Maybe import Data.Monoid import Data.Serialize (Serialize) import Data.Traversable import Distribution.Helper hiding (Programs(..)) import qualified Distribution.Helper as CH import qualified Language.Haskell.GhcMod.Types as T import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Output import Language.Haskell.GhcMod.CustomPackageDb import Language.Haskell.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 <- withCabal $ 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 <- withCabal $ 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' ] runCHQuery :: (IOish m, GmOut m, GmEnv m) => Query m b -> m b runCHQuery a = do crdl <- cradle let projdir = cradleRootDir crdl distdir = projdir cradleDistDir crdl opts <- options progs <- patchStackPrograms crdl (optPrograms opts) readProc <- gmReadProcess let qe = (defaultQueryEnv projdir distdir) { qeReadProcess = readProc , qePrograms = helperProgs progs } runQuery qe a prepareCabalHelper :: (IOish m, GmEnv m, GmOut m, GmLog m) => m () prepareCabalHelper = do crdl <- cradle let projdir = cradleRootDir crdl distdir = projdir cradleDistDir crdl readProc <- gmReadProcess when (isCabalHelperProject $ cradleProject crdl) $ withCabal $ liftIO $ prepare readProc projdir distdir withCabal :: (IOish m, GmEnv m, GmOut m, GmLog m) => m a -> m a withCabal action = do crdl <- cradle opts <- options readProc <- gmReadProcess let projdir = cradleRootDir crdl distdir = projdir cradleDistDir crdl mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl) mCabalSandboxConfig <- liftIO $ timeMaybe (sandboxConfigFile crdl) mCusPkgDbStack <- getCustomPkgDbStack pkgDbStackOutOfSync <- case mCusPkgDbStack of Just cusPkgDbStack -> do let qe = (defaultQueryEnv projdir distdir) { qeReadProcess = readProc , qePrograms = helperProgs $ optPrograms opts } pkgDb <- runQuery qe $ map chPkgToGhcPkg <$> packageDbStack return $ pkgDb /= cusPkgDbStack Nothing -> return False proj <- cradleProject <$> cradle when (isSetupConfigOutOfDate mCabalFile mCabalConfig) $ gmLog GmDebug "" $ strDoc $ "setup configuration is out of date, reconfiguring Cabal project." when (isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $ gmLog GmDebug "" $ strDoc $ "sandbox configuration is out of date, reconfiguring Cabal project." when pkgDbStackOutOfSync $ gmLog GmDebug "" $ strDoc $ "package-db stack out of sync with ghc-mod.package-db-stack, reconfiguring Cabal project." when ( isSetupConfigOutOfDate mCabalFile mCabalConfig || pkgDbStackOutOfSync || isSetupConfigOutOfDate mCabalSandboxConfig mCabalConfig) $ case proj of CabalProject -> cabalReconfigure readProc (optPrograms opts) crdl projdir distdir StackProject {} -> stackReconfigure crdl (optPrograms opts) _ -> error $ "withCabal: unsupported project type: " ++ show proj action where writeAutogen projdir distdir = do readProc <- gmReadProcess gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files" liftIO $ writeAutogenFiles readProc projdir distdir cabalReconfigure readProc progs crdl projdir distdir = do 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 liftIO $ void $ readProc (T.cabalProgram progs) ("configure":progOpts) "" writeAutogen projdir distdir stackReconfigure crdl progs = do let projdir = cradleRootDir crdl distdir = projdir cradleDistDir crdl withDirectory_ (cradleRootDir crdl) $ do supported <- haveStackSupport if supported then do spawn [T.stackProgram progs, "build", "--only-dependencies", "."] spawn [T.stackProgram progs, "build", "--only-configure", "."] writeAutogen projdir distdir 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, Serialize 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 disdir 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 , (gmVer, chVer) ) gmVer = GhcMod.version chVer = VERSION_cabal_helper ghc-mod-5.4.0.0/Language/Haskell/GhcMod/Caching.hs0000644000000000000000000000742212576164335017542 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Language.Haskell.GhcMod.Caching ( module Language.Haskell.GhcMod.Caching , module Language.Haskell.GhcMod.Caching.Types ) where import Control.Arrow (first) import Control.Monad import Control.Monad.Trans.Maybe import Data.Maybe import Data.Serialize (Serialize, encode, decode) import Data.Version import Data.Label import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import System.FilePath import Utils (TimedFile(..), timeMaybe, mightExist) import Paths_ghc_mod (version) import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Caching.Types import Language.Haskell.GhcMod.Logging -- | Cache a MonadIO action with proper invalidation. cached :: forall m a d. (Gm m, MonadIO m, Serialize a, Eq d, Serialize d, Show d) => FilePath -- ^ Directory to prepend to 'cacheFile' -> Cached m GhcModState d a -- ^ Cache descriptor -> d -> m a cached dir cd d = do mcc <- readCache tcfile <- liftIO $ timeMaybe (cacheFile cd) case mcc of Nothing -> writeCache (TimedCacheFiles tcfile []) Nothing "cache missing or unreadable" Just (ifs, d', a) | d /= d' -> do tcf <- timeCacheInput dir (cacheFile cd) ifs writeCache tcf (Just a) $ "input data changed" -- ++ " was: " ++ show d ++ " is: " ++ show d' Just (ifs, _, a) -> do tcf <- timeCacheInput dir (cacheFile cd) ifs case invalidatingInputFiles tcf of Just [] -> return a Just _ -> writeCache tcf (Just a) "input files changed" Nothing -> writeCache tcf (Just a) "cache missing, existed a sec ago WTF?" where cacheHeader = BS8.pack $ "Written by ghc-mod " ++ showVersion version ++ "\n" writeCache tcf ma cause = do (ifs', a) <- (cachedAction cd) tcf d ma gmLog GmDebug "" $ (text "regenerating cache") <+>: text (cacheFile cd) <+> parens (text cause) case cacheLens cd of Nothing -> return () Just label -> do gmLog GmDebug "" $ (text "writing memory cache") <+>: text (cacheFile cd) setLabel label $ Just (ifs', d, a) liftIO $ BS.writeFile (dir cacheFile cd) $ BS.append cacheHeader $ encode (ifs', d, a) return a setLabel l x = do s <- gmsGet gmsPut $ set l x s readCache :: m (Maybe ([FilePath], d, a)) readCache = runMaybeT $ do case cacheLens cd of Just label -> do c <- MaybeT (get label `liftM` gmsGet) `mplus` readCacheFromFile setLabel label $ Just c return c Nothing -> readCacheFromFile readCacheFromFile = do f <- MaybeT $ liftIO $ mightExist $ cacheFile cd readCacheFromFile' f readCacheFromFile' f = MaybeT $ do gmLog GmDebug "" $ (text "reading cache") <+>: text (cacheFile cd) cc <- liftIO $ BS.readFile f case first BS8.words $ BS8.span (/='\n') cc of (["Written", "by", "ghc-mod", ver], rest) | BS8.unpack ver == showVersion version -> return $ either (const Nothing) Just $ decode $ BS.drop 1 rest _ -> return Nothing timeCacheInput :: MonadIO m => FilePath -> FilePath -> [FilePath] -> m TimedCacheFiles timeCacheInput dir cfile ifs = liftIO $ do -- TODO: is checking the times this way around race free? ins <- (timeMaybe . (dir )) `mapM` ifs mtcfile <- timeMaybe cfile return $ TimedCacheFiles mtcfile (catMaybes ins) invalidatingInputFiles :: TimedCacheFiles -> Maybe [FilePath] invalidatingInputFiles tcf = case tcCacheFile tcf of Nothing -> Nothing Just tcfile -> Just $ map tfPath $ -- get input files older than tcfile filter (tcfile<) $ tcFiles tcf ghc-mod-5.4.0.0/Language/Haskell/GhcMod/CaseSplit.hs0000644000000000000000000002572512576164335020103 0ustar0000000000000000{-# LANGUAGE CPP #-} module Language.Haskell.GhcMod.CaseSplit ( splits ) where import Data.List (find, intercalate) import Data.Maybe (isJust) import qualified Data.Text as T import qualified Data.Text.IO as T (readFile) import 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 Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.DynFlags import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.SrcUtils import Language.Haskell.GhcMod.Doc import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping) ---------------------------------------------------------------- -- 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 -> case x of (SplitInfo varName bndLoc (varLoc,varT) _matches) -> do let varName' = showName dflag style varName -- Convert name to string t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $ getTyCons dflag style varName varT) return (fourInts bndLoc, t) (TySplitInfo varName bndLoc (varLoc,varT)) -> do let varName' = showName dflag style varName -- Convert name to string t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $ getTyCons dflag style varName varT) return (fourInts bndLoc, t) where handler (SomeException ex) = do gmLog GmException "splits" $ text "" $$ nest 4 (showDoc 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 getPatternVarName (L _ (G.VarPat vName)) = G.getName vName getPatternVarName _ = error "This should never happened" -- TODO: Information for a type family case split getSrcSpanTypeForTypeSplit :: GhcMonad m => G.ModSummary -> Int -> Int -> m (Maybe SplitInfo) getSrcSpanTypeForTypeSplit _modSum _lineNo _colNo = return Nothing ---------------------------------------------------------------- -- b. Code for getting the possible constructors getTyCons :: DynFlags -> PprStyle -> G.Name -> G.Type -> [String] getTyCons dflag style name ty | Just (tyCon, _) <- Ty.splitTyConApp_maybe ty = let name' = showName dflag style name -- Convert name to string in getTyCon dflag style name' tyCon getTyCons dflag style name _ = [showName dflag style name] -- Write cases for one type getTyCon :: DynFlags -> PprStyle -> String -> Ty.TyCon -> [String] -- 1. Non-matcheable type constructors getTyCon _ _ name tyCon | isNotMatcheableTyCon tyCon = [name] -- 2. Special cases -- 2.1. Tuples getTyCon _ _ name tyCon | Ty.isTupleTyCon tyCon = let [uniqueDataCon] = Ty.tyConDataCons tyCon tupleArity = Ty.dataConSourceArity uniqueDataCon -- Deal with both boxed and unboxed tuples isUnboxed = Ty.isUnboxedTupleTyCon tyCon startSign = if isUnboxed then "(#" else "(" endSign = if isUnboxed then "#)" else ")" in [ startSign ++ intercalate "," (map (\n -> name ++ show n) [1 .. tupleArity]) ++ endSign ] -- 3. General case getTyCon dflag style name tyCon = map (getDataCon dflag style name) (Ty.tyConDataCons tyCon) -- These type constructors should not be matched against isNotMatcheableTyCon :: Ty.TyCon -> Bool isNotMatcheableTyCon ty = Ty.isPrimTyCon ty -- Primitive types, such as Int# || Ty.isFunTyCon ty -- Function types -- Write case for one constructor getDataCon :: DynFlags -> PprStyle -> String -> Ty.DataCon -> String -- 1. Infix constructors getDataCon dflag style vName dcon | Ty.dataConIsInfix dcon = let dName = showName dflag style $ Ty.dataConName dcon in case Ty.dataConSourceArity dcon of 0 -> dName 1 -> vName ++ dName n -> if dName == ":" -- Special case for lists then vName ++ ":" ++ vName ++ "s" else newVar vName 1 ++ " " ++ dName ++ " " ++ newVars vName 2 (n-1) -- 2. Non-record, non-infix syntax getDataCon dflag style vName dcon | [] <- Ty.dataConFieldLabels dcon = let dName = showName dflag style $ Ty.dataConName dcon in if last dName == '#' -- Special case for I#, C# and so on then vName else case Ty.dataConSourceArity dcon of 0 -> dName _ -> dName ++ " " ++ newVarsSpecialSingleton vName 1 (Ty.dataConSourceArity dcon) -- 3. Records getDataCon dflag style vName dcon = let dName = showName dflag style $ Ty.dataConName dcon flds = Ty.dataConFieldLabels dcon in dName ++ " { " ++ showFieldNames dflag style vName flds ++ " }" -- Create a new variable by adjoining a number newVar :: String -> Int -> String newVar v n = v ++ show n -- Create a list of variables which start with the same prefix newVars :: String -> Int -> Int -> String newVars _ _ 0 = "" newVars v s 1 = newVar v s newVars v s m = newVar v s ++ " " ++ newVars v (s+1) (m-1) -- Create a list of variables which start with the same prefix -- Special case for a single variable, in which case no number is adjoint newVarsSpecialSingleton :: String -> Int -> Int -> String newVarsSpecialSingleton v _ 1 = v newVarsSpecialSingleton v start n = newVars v start n showFieldNames :: DynFlags -> PprStyle -> String -> [G.Name] -> String showFieldNames _ _ _ [] = "" -- This should never happen showFieldNames dflag style v (x:xs) = let fName = showName dflag style x fAcc = fName ++ " = " ++ v ++ "_" ++ fName in case xs of [] -> fAcc _ -> fAcc ++ ", " ++ showFieldNames dflag style v xs ---------------------------------------------------------------- -- c. Code for performing the case splitting genCaseSplitTextFile :: (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.4.0.0/Language/Haskell/GhcMod/Check.hs0000644000000000000000000000322712576164335017222 0ustar0000000000000000module Language.Haskell.GhcMod.Check ( checkSyntax , check , expandTemplate , expand ) where import Control.Applicative import Prelude import Language.Haskell.GhcMod.DynFlags import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Logger import Language.Haskell.GhcMod.Monad ---------------------------------------------------------------- -- | 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 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.4.0.0/Language/Haskell/GhcMod/Convert.hs0000644000000000000000000001157012576164335017625 0ustar0000000000000000{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-} module Language.Haskell.GhcMod.Convert (convert, convert', emptyResult, whenFound, whenFound') where import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.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.4.0.0/Language/Haskell/GhcMod/Cradle.hs0000644000000000000000000001013112576164335017367 0ustar0000000000000000{-# LANGUAGE CPP #-} module Language.Haskell.GhcMod.Cradle #ifndef SPEC ( findCradle , findCradle' , findSpecCradle , cleanupCradle ) #endif where import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.Stack import Control.Applicative import Control.Monad import Control.Monad.Trans.Maybe import Data.Maybe import System.Directory import System.FilePath import Prelude ---------------------------------------------------------------- -- | Finding 'Cradle'. -- Find a cabal file by tracing ancestor directories. -- Find a sandbox according to a cabal sandbox config -- in a cabal directory. findCradle :: (IOish m, GmOut m) => m Cradle findCradle = findCradle' =<< liftIO getCurrentDirectory findCradle' :: (IOish m, GmOut m) => FilePath -> m Cradle findCradle' dir = run $ msum [ stackCradle dir , cabalCradle dir , sandboxCradle dir , plainCradle dir ] where run a = fillTempDir =<< (fromJust <$> runMaybeT a) findSpecCradle :: (IOish m, GmOut m) => FilePath -> m Cradle findSpecCradle dir = do let cfs = [stackCradleSpec, cabalCradle, sandboxCradle] cs <- catMaybes <$> mapM (runMaybeT . ($ dir)) cfs gcs <- filterM isNotGmCradle cs fillTempDir =<< case gcs of [] -> fromJust <$> runMaybeT (plainCradle dir) c:_ -> return c where isNotGmCradle 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 => FilePath -> MaybeT m Cradle cabalCradle wdir = do cabalFile <- MaybeT $ liftIO $ findCabalFile wdir let cabalDir = takeDirectory cabalFile return Cradle { cradleProject = CabalProject , cradleCurrentDir = wdir , cradleRootDir = cabalDir , cradleTempDir = error "tmpDir" , cradleCabalFile = Just cabalFile , cradleDistDir = "dist" } stackCradle :: (IOish m, GmOut m) => FilePath -> MaybeT m Cradle stackCradle wdir = do cabalFile <- MaybeT $ liftIO $ findCabalFile wdir let cabalDir = takeDirectory cabalFile _stackConfigFile <- MaybeT $ liftIO $ findStackConfigFile cabalDir -- If dist/setup-config already exists the user probably wants to use cabal -- rather than stack, or maybe that's just me ;) whenM (liftIO $ doesFileExist $ setupConfigPath "dist") $ mzero senv <- MaybeT $ getStackEnv cabalDir return Cradle { cradleProject = StackProject senv , cradleCurrentDir = wdir , cradleRootDir = cabalDir , cradleTempDir = error "tmpDir" , cradleCabalFile = Just cabalFile , cradleDistDir = seDistDir senv } stackCradleSpec :: (IOish m, GmOut m) => FilePath -> MaybeT m Cradle stackCradleSpec wdir = do crdl <- stackCradle 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 => FilePath -> MaybeT m Cradle sandboxCradle wdir = do sbDir <- MaybeT $ liftIO $ findCabalSandboxDir wdir return Cradle { cradleProject = SandboxProject , cradleCurrentDir = wdir , cradleRootDir = sbDir , cradleTempDir = error "tmpDir" , cradleCabalFile = Nothing , cradleDistDir = "dist" } plainCradle :: IOish m => FilePath -> MaybeT m Cradle plainCradle wdir = do return $ Cradle { cradleProject = PlainProject , cradleCurrentDir = wdir , cradleRootDir = wdir , cradleTempDir = error "tmpDir" , cradleCabalFile = Nothing , cradleDistDir = "dist" } ghc-mod-5.4.0.0/Language/Haskell/GhcMod/CustomPackageDb.hs0000644000000000000000000000144112576164335021175 0ustar0000000000000000module Language.Haskell.GhcMod.CustomPackageDb where import Control.Applicative import Control.Monad import Control.Category ((.)) import Data.Maybe import Data.Traversable import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.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 :: (IOish m, GmEnv m) => m (Maybe [GhcPkgDb]) getCustomPkgDbStack = do mCusPkgDbFile <- liftIO . (traverse readFile <=< findCustomPackageDbFile) . cradleRootDir =<< cradle return $ parseCustomPackageDb <$> mCusPkgDbFile ghc-mod-5.4.0.0/Language/Haskell/GhcMod/Debug.hs0000644000000000000000000001145712576164335017237 0ustar0000000000000000module Language.Haskell.GhcMod.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.List.Split import Text.PrettyPrint import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Internal import Language.Haskell.GhcMod.Target import Language.Haskell.GhcMod.Pretty import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.Stack ---------------------------------------------------------------- -- | Obtaining debug information. debugInfo :: IOish m => GhcModT m String debugInfo = do Options {..} <- options Cradle {..} <- cradle cabal <- case cradleProject of CabalProject -> cabalDebug StackProject {} -> (++) <$> stackPaths <*> cabalDebug _ -> return [] pkgOpts <- packageGhcOptions return $ unlines $ [ "Root directory: " ++ cradleRootDir , "Current directory: " ++ cradleCurrentDir , "GHC Package flags:\n" ++ render (nest 4 $ fsep $ map text pkgOpts) , "GHC System libraries: " ++ ghcLibDir , "GHC user options:\n" ++ render (nest 4 $ fsep $ map text optGhcUserOptions) ] ++ 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 => GhcModT m [String] cabalDebug = do Cradle {..} <- cradle mcs <- cabalResolvedComponents let entrypoints = Map.map gmcEntrypoints mcs graphs = Map.map gmcHomeModuleGraph mcs opts = Map.map gmcGhcOpts mcs srcOpts = Map.map gmcGhcSrcOpts mcs return $ [ "Cabal file: " ++ show cradleCabalFile , "Project: " ++ show cradleProject , "Cabal entrypoints:\n" ++ render (nest 4 $ mapDoc gmComponentNameDoc smpDoc entrypoints) , "Cabal components:\n" ++ render (nest 4 $ mapDoc gmComponentNameDoc graphDoc graphs) , "GHC Cabal options:\n" ++ render (nest 4 $ mapDoc gmComponentNameDoc (fsep . map text) opts) , "GHC search path options:\n" ++ render (nest 4 $ mapDoc gmComponentNameDoc (fsep . map text) srcOpts) ] componentInfo :: IOish m => [String] -> GhcModT m String componentInfo ts = do -- TODO: most of this is copypasta of targetGhcOptions. Factor out more -- useful function from there. crdl <- cradle sefnmn <- Set.fromList `liftM` mapM guessModuleFile ts mcs <- cabalResolvedComponents let mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn candidates = findCandidates $ map snd mdlcs cn = pickComponent candidates opts <- targetGhcOptions crdl sefnmn return $ unlines $ [ "Matching Components:\n" ++ render (nest 4 $ alistDoc (either text mnDoc) (setDoc gmComponentNameDoc) mdlcs) , "Picked Component:\n" ++ render (nest 4 $ gmComponentNameDoc cn) , "GHC Cabal options:\n" ++ render (nest 4 $ fsep $ map text opts) ] where zipMap f l = l `zip` (f `map` l) guessModuleFile :: MonadIO m => String -> m (Either FilePath ModuleName) guessModuleFile m | (isUpper . head .&&. (all $ all $ isAlphaNum .||. (=='.')) . splitOn ".") m = return $ Right $ mkModuleName m where infixr 1 .||. infixr 2 .&&. (.||.) = liftA2 (||) (.&&.) = liftA2 (&&) guessModuleFile str = Left `liftM` liftIO (canonFilePath str) graphDoc :: GmModuleGraph -> Doc graphDoc GmModuleGraph{..} = mapDoc mpDoc smpDoc' gmgGraph where smpDoc' smp = vcat $ map mpDoc' $ Set.toList smp mpDoc' = text . moduleNameString . mpModule setDoc :: (a -> Doc) -> Set.Set a -> Doc setDoc f s = vcat $ map f $ Set.toList s smpDoc :: Set.Set ModulePath -> Doc smpDoc smp = setDoc mpDoc smp mpDoc :: ModulePath -> Doc mpDoc (ModulePath mn fn) = text (moduleNameString mn) <+> parens (text fn) mnDoc :: ModuleName -> Doc mnDoc mn = text (moduleNameString mn) alistDoc :: Ord k => (k -> Doc) -> (a -> Doc) -> [(k, a)] -> Doc alistDoc fk fa alist = mapDoc fk fa (Map.fromList alist) mapDoc :: (k -> Doc) -> (a -> Doc) -> Map.Map k a -> Doc mapDoc kd ad m = vcat $ map (uncurry ($+$)) $ map (first kd) $ Map.toList $ Map.map (nest 4 . ad) m ---------------------------------------------------------------- -- | Obtaining root information. rootInfo :: (IOish m, GmOut m) => m String rootInfo = (++"\n") . cradleRootDir <$> findCradle ghc-mod-5.4.0.0/Language/Haskell/GhcMod/DebugLogger.hs0000644000000000000000000000574412576164335020401 0ustar0000000000000000{-# LANGUAGE CPP #-} module Language.Haskell.GhcMod.DebugLogger where import GHC import FastString import Pretty import Outputable (SDoc, PprStyle, runSDoc, initSDocContext, blankLine) import qualified Outputable import ErrUtils import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Gap import Prelude debugLogAction :: (String -> IO ()) -> GmLogAction debugLogAction putErr 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.4.0.0/Language/Haskell/GhcMod/Doc.hs0000644000000000000000000000151112576164335016704 0ustar0000000000000000module Language.Haskell.GhcMod.Doc where import GHC import Language.Haskell.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 -- showForUser :: DynFlags -> PrintUnqualified -> SDoc -> String -- showForUser dflags unqual sdoc = -- showDocWith dflags PageMode $ -- runSDoc sdoc $ initSDocContext dflags $ mkUserStyle unqual AllTheWay getStyle :: GhcMonad m => m PprStyle getStyle = do unqual <- getPrintUnqual return $ mkUserStyle unqual AllTheWay styleUnqualified :: PprStyle styleUnqualified = mkUserStyle neverQualify AllTheWay ghc-mod-5.4.0.0/Language/Haskell/GhcMod/DynFlags.hs0000644000000000000000000000627012576164335017715 0ustar0000000000000000{-# LANGUAGE CPP #-} module Language.Haskell.GhcMod.DynFlags where import Control.Applicative import Control.Monad import GHC import qualified GHC as G import GHC.Paths (libdir) import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.DebugLogger 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 setModeSimple :: DynFlags -> DynFlags setModeSimple df = df { ghcMode = CompManager , ghcLink = NoLink , hscTarget = HscNothing , optLevel = 0 } -- * Slow -- * Not friendly to foreign export -- * Friendly to -XTemplateHaskell and -XPatternSynonyms -- * Uses lots of memory setModeIntelligent :: DynFlags -> DynFlags setModeIntelligent df = df { ghcMode = CompManager , ghcLink = LinkInMemory , hscTarget = HscInterpreted , optLevel = 0 } -- | 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' ---------------------------------------------------------------- -- | Set 'DynFlags' equivalent to "-fno-max-relevant-bindings". setNoMaxRelevantBindings :: DynFlags -> DynFlags #if __GLASGOW_HASKELL__ >= 708 setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing } #else setNoMaxRelevantBindings = id #endif deferErrors :: DynFlags -> Ghc DynFlags deferErrors df = return $ Gap.setWarnTypedHoles $ Gap.setDeferTypedHoles $ Gap.setDeferTypeErrors $ setNoWarningFlags df ghc-mod-5.4.0.0/Language/Haskell/GhcMod/Error.hs0000644000000000000000000001356612576164335017305 0ustar0000000000000000-- ghc-mod: Making Haskell development *more* fun -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE ExistentialQuantification #-} module Language.Haskell.GhcMod.Error ( GhcModError(..) , 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.PrettyPrint import Text.Printf import Exception import Panic import Config (cProjectVersion, cHostPlatformString) import Paths_ghc_mod (version) import Language.Haskell.GhcMod.Types import Language.Haskell.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 ++"\"." GMEWrongWorkingDirectory projdir cdir -> (text $ "You must run ghc-mod in the project directory as returned by `ghc-mod root`.") <+> text "Currently in:" <+> showDoc cdir <> text "but should be in" <+> showDoc projdir <> text "." 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.4.0.0/Language/Haskell/GhcMod/FileMapping.hs0000644000000000000000000000477612576164335020412 0ustar0000000000000000module Language.Haskell.GhcMod.FileMapping ( loadMappedFile , loadMappedFileSource , unloadMappedFile , mapFile , fileModSummaryWithMapping ) where import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Gap import Language.Haskell.GhcMod.HomeModuleGraph import Language.Haskell.GhcMod.Utils import System.IO import System.FilePath import System.Directory import Control.Monad.Trans.Maybe import GHC import Control.Monad loadMappedFile :: IOish m => FilePath -> FilePath -> GhcModT m () loadMappedFile from to = loadMappedFile' from to False loadMappedFileSource :: IOish m => FilePath -> String -> GhcModT m () loadMappedFileSource from src = do tmpdir <- cradleTempDir `fmap` cradle to <- liftIO $ do (fn, h) <- openTempFile tmpdir (takeFileName from) 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 addMMappedFile cfn (FileMapping to isTemp) mapFile :: (IOish m, GmState m, GhcMonad m, GmEnv m) => HscEnv -> Target -> m Target mapFile _ (Target tid@(TargetFile filePath _) taoc _) = do mapping <- lookupMMappedFile filePath 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) mkMappedTarget fp tid taoc mapping mkMappedTarget :: (IOish m, GmState m, GmEnv m, GhcMonad m) => Maybe FilePath -> TargetId -> Bool -> Maybe FileMapping -> m Target mkMappedTarget _ _ taoc (Just to) = return $ mkTarget (TargetFile (fmPath to) Nothing) taoc Nothing mkMappedTarget _ tid taoc _ = return $ mkTarget tid taoc Nothing unloadMappedFile :: IOish m => FilePath -> 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.4.0.0/Language/Haskell/GhcMod/FillSig.hs0000644000000000000000000005364712576164335017551 0ustar0000000000000000{-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies #-} {-# LANGUAGE FlexibleInstances #-} module Language.Haskell.GhcMod.FillSig ( sig , refine , auto ) where import Data.Char (isSymbol) import Data.Function (on) import Data.Functor import Data.List (find, nub, sortBy) import qualified Data.Map as M import Data.Maybe (catMaybes) import Text.PrettyPrint (($$), text, nest) import Prelude import Exception (ghandle, SomeException(..)) import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) import qualified GHC as G import qualified Name as G import Outputable (PprStyle) import qualified Type as Ty import qualified HsBinds as Ty import qualified Class as Ty import qualified Var as Ty import qualified HsPat as Ty import qualified Language.Haskell.Exts.Annotated as HE import Djinn.GHC import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.SrcUtils import Language.Haskell.GhcMod.Logging (gmLog) import Language.Haskell.GhcMod.Pretty (showDoc) import Language.Haskell.GhcMod.Doc import Language.Haskell.GhcMod.Types import Language.Haskell.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__ >= 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__ >= 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__ >= 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__ >= 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__ >= 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 (showDoc 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 e@(L _ (G.HsVar i)):others -> do tyInfo <- Gap.getType tcm e case tyInfo of Just (s, typ) | name == "undefined" || head name == '_' -> return $ Just (s, name, typ, b) where name = getFnName dflag style i -- If inside an App, we need parenthesis b = case others of L _ (G.HsApp (L _ a1) (L _ a2)):_ -> isSearchedVar i a1 || isSearchedVar i a2 _ -> False _ -> return Nothing _ -> return Nothing where lst :: [G.LHsExpr Id] lst = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo) infinitePrefixSupply :: String -> [String] infinitePrefixSupply "undefined" = repeat "undefined" infinitePrefixSupply p = map (\n -> p ++ "_" ++ show n) ([1 ..] :: [Integer]) doParen :: Bool -> String -> String doParen False s = s doParen True s = if ' ' `elem` s then '(':s ++ ")" else s isSearchedVar :: Id -> G.HsExpr Id -> Bool isSearchedVar i (G.HsVar i2) = i == i2 isSearchedVar _ _ = False ---------------------------------------------------------------- -- REFINE AUTOMATICALLY ---------------------------------------------------------------- auto :: IOish m => FilePath -- ^ A target file. -> Int -- ^ Line number. -> Int -- ^ Column number. -> GhcModT m String auto file lineNo colNo = ghandle handler $ 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 (showDoc 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 getBindingsForPat (Ty.VarPat i) = M.singleton (G.getName i) (Ty.varType i) getBindingsForPat (Ty.LazyPat (L _ l)) = getBindingsForPat l getBindingsForPat (Ty.BangPat (L _ b)) = getBindingsForPat b getBindingsForPat (Ty.AsPat (L _ a) (L _ i)) = M.insert (G.getName a) (Ty.varType a) (getBindingsForPat i) #if __GLASGOW_HASKELL__ >= 708 getBindingsForPat (Ty.ListPat l _ _) = M.unions $ map (\(L _ i) -> getBindingsForPat i) l #else getBindingsForPat (Ty.ListPat l _) = M.unions $ map (\(L _ i) -> getBindingsForPat i) l #endif getBindingsForPat (Ty.TuplePat l _ _) = M.unions $ map (\(L _ i) -> getBindingsForPat i) l getBindingsForPat (Ty.PArrPat l _) = M.unions $ map (\(L _ i) -> getBindingsForPat i) l getBindingsForPat (Ty.ViewPat _ (L _ i) _) = getBindingsForPat i getBindingsForPat (Ty.SigPatIn (L _ i) _) = getBindingsForPat i getBindingsForPat (Ty.SigPatOut (L _ i) _) = getBindingsForPat i getBindingsForPat (Ty.ConPatIn (L _ i) d) = M.insert (G.getName i) (Ty.varType i) (getBindingsForRecPat d) getBindingsForPat (Ty.ConPatOut { Ty.pat_args = d }) = getBindingsForRecPat d getBindingsForPat _ = M.empty getBindingsForRecPat :: Ty.HsConPatDetails Id -> M.Map G.Name Type getBindingsForRecPat (Ty.PrefixCon args) = M.unions $ map (\(L _ i) -> getBindingsForPat i) args getBindingsForRecPat (Ty.InfixCon (L _ a1) (L _ a2)) = M.union (getBindingsForPat a1) (getBindingsForPat a2) getBindingsForRecPat (Ty.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) = getBindingsForRecFields (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.4.0.0/Language/Haskell/GhcMod/Find.hs0000644000000000000000000001113512576164335017062 0ustar0000000000000000{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse #-} module Language.Haskell.GhcMod.Find #ifndef SPEC ( Symbol , SymbolDb , loadSymbolDb , lookupSymbol , dumpSymbol , findSymbol , lookupSym , isOutdated ) #endif where import Control.Applicative import Control.Monad (when, void) import Data.Function (on) import Data.List (groupBy, sort) import qualified GHC as G import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Gap (listVisibleModules) import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.World (timedPackageCaches) import Language.Haskell.GhcMod.Output import Name (getOccString) import Module (moduleName) import System.Directory (doesFileExist, getModificationTime) import System.FilePath (()) import System.IO import Prelude import Data.Map (Map) import qualified Data.Map as M ---------------------------------------------------------------- -- | Type of function and operation names. type Symbol = String -- | Database from 'Symbol' to \['ModuleString'\]. data SymbolDb = SymbolDb { table :: Map Symbol [ModuleString] , symbolDbCachePath :: FilePath } deriving (Show) isOutdated :: IOish m => SymbolDb -> GhcModT m Bool isOutdated db = (liftIO . isOlderThan (symbolDbCachePath db)) =<< timedPackageCaches ---------------------------------------------------------------- -- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\] -- which will be concatenated. 'loadSymbolDb' is called internally. findSymbol :: IOish m => Symbol -> GhcModT m String findSymbol sym = do tmpdir <- cradleTempDir <$> cradle loadSymbolDb tmpdir >>= lookupSymbol sym -- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\] -- which will be concatenated. lookupSymbol :: IOish m => Symbol -> SymbolDb -> GhcModT m String lookupSymbol sym db = convert' $ lookupSym sym db lookupSym :: Symbol -> SymbolDb -> [ModuleString] lookupSym sym db = M.findWithDefault [] sym $ table db --------------------------------------------------------------- -- | Loading a file and creates 'SymbolDb'. loadSymbolDb :: IOish m => FilePath -> GhcModT m SymbolDb loadSymbolDb dir = do ghcMod <- liftIO ghcModExecutable readProc <- gmReadProcess file <- liftIO $ chop <$> readProc ghcMod ["dumpsym", dir] "" !db <- M.fromAscList . map conv . lines <$> liftIO (readFile file) return $ SymbolDb { table = db , symbolDbCachePath = file } where conv :: String -> (Symbol, [ModuleString]) conv = read chop :: String -> String chop "" = "" chop xs = init xs ---------------------------------------------------------------- -- used 'ghc-mod dumpsym' -- | Dumping a set of ('Symbol',\['ModuleString'\]) to a file -- if the file does not exist or is invalid. -- The file name is printed. dumpSymbol :: IOish m => FilePath -> GhcModT m String dumpSymbol dir = do create <- (liftIO . isOlderThan cache) =<< timedPackageCaches runGmPkgGhc $ do when create $ liftIO . writeSymbolCache cache =<< getGlobalSymbolTable return $ unlines [cache] where cache = dir symbolCacheFile writeSymbolCache :: FilePath -> [(Symbol, [ModuleString])] -> IO () writeSymbolCache cache sm = void . withFile cache WriteMode $ \hdl -> mapM (hPrint hdl) sm -- | Check whether given file is older than any file from the given set. -- Returns True if given file does not exist. isOlderThan :: FilePath -> [TimedFile] -> IO Bool isOlderThan cache files = do exist <- doesFileExist cache if not exist then return True else do tCache <- getModificationTime cache return $ any (tCache <=) $ map tfTime files -- including equal just in case -- | Browsing all functions in all system modules. getGlobalSymbolTable :: LightGhc [(Symbol, [ModuleString])] getGlobalSymbolTable = do df <- G.getSessionDynFlags let mods = listVisibleModules df moduleInfos <- mapM G.getModuleInfo mods return $ collectModules $ extractBindings `concatMap` (moduleInfos `zip` mods) extractBindings :: (Maybe G.ModuleInfo, G.Module) -> [(Symbol, ModuleString)] extractBindings (Nothing, _) = [] extractBindings (Just inf, mdl) = map (\name -> (getOccString name, modStr)) names where names = G.modInfoExports inf modStr = ModuleString $ moduleNameString $ moduleName mdl collectModules :: [(Symbol, ModuleString)] -> [(Symbol, [ModuleString])] collectModules = map tieup . groupBy ((==) `on` fst) . sort where tieup x = (head (map fst x), map snd x) ghc-mod-5.4.0.0/Language/Haskell/GhcMod/Flag.hs0000644000000000000000000000062312576164335017053 0ustar0000000000000000module Language.Haskell.GhcMod.Flag where import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Monad -- | Listing GHC flags. (e.g -fno-warn-orphans) flags :: IOish m => GhcModT m String flags = convert' [ "-f" ++ prefix ++ option | option <- Gap.fOptions , prefix <- ["","no-"] ] ghc-mod-5.4.0.0/Language/Haskell/GhcMod/Gap.hs0000644000000000000000000004213612576164335016716 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP, ScopedTypeVariables, RankNTypes #-} module Language.Haskell.GhcMod.Gap ( Language.Haskell.GhcMod.Gap.ClsInst , mkTarget , withStyle , GmLogAction , setLogAction , getSrcSpan , getSrcFile , withInteractiveContext , fOptions , toStringBuffer , showSeverityCaption , setCabalPkg , setHideAllPackages , setDeferTypeErrors , setDeferTypedHoles , setWarnTypedHoles , setDumpSplices , isDumpSplices , filterOutChildren , infoThing , pprInfo , HasType(..) , errorMsgSpan , typeForUser , nameForUser , occNameForUser , deSugar , showDocWith , GapThing(..) , fromTyThing , fileModSummary , WarnFlags , emptyWarnFlags , GLMatch , GLMatchI , getClass , occName , listVisibleModuleNames , listVisibleModules , lookupModulePackageInAllPackages , Language.Haskell.GhcMod.Gap.isSynTyCon , parseModuleHeader , mkErrStyle' ) 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 (dataConRepType) 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 qualified Name import qualified InstEnv import qualified Pretty import qualified StringBuffer as SB #if __GLASGOW_HASKELL__ >= 708 import FamInstEnv import ConLike (ConLike(..)) import PatSyn (patSynType) #else import TcRnTypes #endif #if __GLASGOW_HASKELL__ >= 706 import GHC hiding (ClsInst) #else import GHC hiding (Instance) import Control.Arrow hiding ((<+>)) import Data.Convertible import RdrName (rdrNameOcc) #endif #if __GLASGOW_HASKELL__ < 710 import UniqFM (eltsUFM) import Module #endif #if __GLASGOW_HASKELL__ >= 704 import qualified Data.IntSet as I (IntSet, empty) #endif import Bag import Lexer as L import Parser import SrcLoc import Packages import Language.Haskell.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__ >= 706 type GmLogAction = LogAction #else type GmLogAction = DynFlags -> LogAction #endif setLogAction :: DynFlags -> GmLogAction -> DynFlags setLogAction df f = #if __GLASGOW_HASKELL__ >= 706 df { log_action = f } #else df { log_action = f df } #endif showDocWith :: DynFlags -> Pretty.Mode -> Pretty.Doc -> String #if __GLASGOW_HASKELL__ >= 708 -- Pretty.showDocWith disappeard. -- https://github.com/ghc/ghc/commit/08a3536e4246e323fbcd8040e0b80001950fe9bc showDocWith dflags mode = Pretty.showDoc mode (pprCols dflags) #else showDocWith _ = Pretty.showDocWith #endif ---------------------------------------------------------------- ---------------------------------------------------------------- getSrcSpan :: SrcSpan -> Maybe (Int,Int,Int,Int) #if __GLASGOW_HASKELL__ >= 702 getSrcSpan (RealSrcSpan spn) #else getSrcSpan spn | isGoodSrcSpan spn #endif = Just (srcSpanStartLine spn , srcSpanStartCol spn , srcSpanEndLine spn , srcSpanEndCol spn) getSrcSpan _ = Nothing getSrcFile :: SrcSpan -> Maybe String #if __GLASGOW_HASKELL__ >= 702 getSrcFile (RealSrcSpan spn) = Just . unpackFS . srcSpanFile $ spn #else getSrcFile spn | isGoodSrcSpan spn = Just . unpackFS . srcSpanFile $ spn #endif getSrcFile _ = Nothing ---------------------------------------------------------------- toStringBuffer :: GhcMonad m => [String] -> m StringBuffer #if __GLASGOW_HASKELL__ >= 702 toStringBuffer = return . stringToStringBuffer . unlines #else toStringBuffer = liftIO . stringToStringBuffer . unlines #endif ---------------------------------------------------------------- fOptions :: [String] #if __GLASGOW_HASKELL__ >= 710 fOptions = [option | (FlagSpec option _ _ _) <- fFlags] ++ [option | (FlagSpec option _ _ _) <- fWarningFlags] ++ [option | (FlagSpec option _ _ _) <- fLangFlags] #elif __GLASGOW_HASKELL__ >= 704 fOptions = [option | (option,_,_) <- fFlags] ++ [option | (option,_,_) <- fWarningFlags] ++ [option | (option,_,_) <- fLangFlags] #else fOptions = [option | (option,_,_,_) <- fFlags] ++ [option | (option,_,_,_) <- fWarningFlags] ++ [option | (option,_,_,_) <- fLangFlags] #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 ---------------------------------------------------------------- ---------------------------------------------------------------- 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 $$ InstEnv.pprInstances insts $$ pprFamInsts 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' = hang (pprTyThingInContext thing') 2 (char '\t' <> ptext (sLit "--") <+> loc) where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing') #else pprTyThingInContextLoc' pefas thing' = hang (pprTyThingInContext pefas thing') 2 (char '\t' <> ptext (sLit "--") <+> loc) where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing') #endif 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 typeForUser :: Type -> SDoc #if __GLASGOW_HASKELL__ >= 708 typeForUser = pprTypeForUser #else typeForUser = pprTypeForUser False #endif nameForUser :: Name -> SDoc nameForUser = pprOccName . getOccName occNameForUser :: OccName -> SDoc occNameForUser = pprOccName deSugar :: TypecheckedModule -> LHsExpr Id -> HscEnv -> IO (Maybe CoreExpr) #if __GLASGOW_HASKELL__ >= 708 deSugar _ e hs_env = snd <$> deSugarExpr hs_env e #else deSugar tcm e hs_env = snd <$> deSugarExpr hs_env modu rn_env ty_env e where modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm tcgEnv = fst $ tm_internals_ tcm rn_env = tcg_rdr_env tcgEnv ty_env = tcg_type_env tcgEnv #endif ---------------------------------------------------------------- ---------------------------------------------------------------- data GapThing = GtA Type | GtT TyCon | GtN fromTyThing :: TyThing -> GapThing fromTyThing (AnId i) = GtA $ varType i #if __GLASGOW_HASKELL__ >= 708 fromTyThing (AConLike (RealDataCon d)) = GtA $ dataConRepType d fromTyThing (AConLike (PatSynCon p)) = GtA $ patSynType p #else fromTyThing (ADataCon d) = GtA $ dataConRepType d #endif fromTyThing (ATyCon t) = GtT t fromTyThing _ = GtN ---------------------------------------------------------------- ---------------------------------------------------------------- #if __GLASGOW_HASKELL__ >= 704 type WarnFlags = I.IntSet emptyWarnFlags :: WarnFlags emptyWarnFlags = I.empty #else type WarnFlags = [WarningFlag] emptyWarnFlags :: WarnFlags emptyWarnFlags = [] #endif ---------------------------------------------------------------- ---------------------------------------------------------------- #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__ >= 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 ghc-mod-5.4.0.0/Language/Haskell/GhcMod/GhcPkg.hs0000644000000000000000000000747412576164335017360 0ustar0000000000000000{-# LANGUAGE BangPatterns, ScopedTypeVariables, TupleSections #-} module Language.Haskell.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 Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.CabalHelper import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.CustomPackageDb import Language.Haskell.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 $ map PackageDb [seSnapshotPkgDb, 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.4.0.0/Language/Haskell/GhcMod/HomeModuleGraph.hs0000644000000000000000000002215512576164335021226 0ustar0000000000000000-- ghc-mod: Making Haskell development *more* fun -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE ScopedTypeVariables, RecordWildCards #-} module Language.Haskell.GhcMod.HomeModuleGraph ( GmModuleGraph(..) , ModulePath(..) , mkFileMap , mkModuleMap , mkMainModulePath , findModulePath , findModulePathSet , fileModuleName , canonicalizeModulePath , homeModuleGraph , updateHomeModuleGraph , canonicalizeModuleGraph , reachable , moduleGraphToDot ) where import DriverPipeline import DynFlags import ErrUtils import Exception import Finder import GHC import HscTypes import Control.Arrow ((&&&)) import Control.Applicative import Control.Monad import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) import Control.Monad.State.Strict (execStateT) import Control.Monad.State.Class import Data.Maybe import Data.Monoid as Monoid import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import System.FilePath import System.Directory import System.IO import Prelude import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Logger import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils (withMappedFile) import Language.Haskell.GhcMod.Gap (parseModuleHeader) -- | Turn module graph into a graphviz dot file -- -- @dot -Tpng -o modules.png modules.dot@ moduleGraphToDot :: GmModuleGraph -> String moduleGraphToDot GmModuleGraph { gmgGraph } = "digraph {\n" ++ concatMap edges (Map.toList graph) ++ "}\n" where graph = Map.map (Set.mapMonotonic mpPath) $ Map.mapKeysMonotonic mpPath gmgGraph edges :: (FilePath, (Set FilePath)) -> String edges (f, sf) = concatMap (\f' -> " \""++ f ++"\" -> \""++ f' ++"\"\n") (Set.toList sf) data S = S { sErrors :: [(ModulePath, ErrorMessages)], sWarnings :: [(ModulePath, WarningMessages)], sGraph :: GmModuleGraph } defaultS :: S defaultS = S [] [] mempty putErr :: MonadState S m => (ModulePath, ErrorMessages) -> m () putErr e = do s <- get put s { sErrors = e:sErrors s} putWarn :: MonadState S m => (ModulePath, ErrorMessages) -> m () putWarn w = do s <- get put s { sWarnings = w:sWarnings s} gmgLookupMP :: MonadState S m => ModulePath -> m (Maybe (Set ModulePath)) gmgLookupMP k = (Map.lookup k . gmgGraph . sGraph) `liftM` get graphUnion :: MonadState S m => GmModuleGraph -> m () graphUnion gmg = do s <- get put s { sGraph = sGraph s `mappend` gmg } reachable :: Set ModulePath -> GmModuleGraph -> Set ModulePath reachable smp0 GmModuleGraph {..} = go smp0 where go smp = let δsmp = Set.unions $ collapseMaybeSet . flip Map.lookup gmgGraph <$> Set.toList smp smp' = smp `Set.union` δsmp in if smp == smp' then smp' else go smp' pruneUnreachable :: Set ModulePath -> GmModuleGraph -> GmModuleGraph pruneUnreachable smp0 gmg@GmModuleGraph {..} = let r = reachable smp0 gmg in GmModuleGraph { gmgGraph = Map.filterWithKey (\k _ -> k `Set.member` r) gmgGraph } collapseMaybeSet :: Maybe (Set a) -> Set a collapseMaybeSet = maybe Set.empty id homeModuleGraph :: (IOish m, 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) $ Monoid.mempty $+$ (vcat $ map text errs) return Nothing imports :: ModulePath -> String -> DynFlags -> MaybeT m (Set ModulePath) imports mp@ModulePath {..} src dflags = case parseModuleHeader src dflags mpPath of Left err -> do putErr (mp, err) mzero Right (ws, lmdl) -> do putWarn (mp, ws) let HsModule {..} = unLoc lmdl mns = map (unLoc . ideclName) $ filter (isNothing . ideclPkgQual) $ map unLoc hsmodImports liftIO $ Set.fromList . catMaybes <$> mapM (findModulePath env) mns preprocessFile :: (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.4.0.0/Language/Haskell/GhcMod/Info.hs0000644000000000000000000000565712576164335017111 0ustar0000000000000000module Language.Haskell.GhcMod.Info ( info , types ) where import Data.Function (on) import Data.List (sortBy) import Data.Maybe (catMaybes) import System.FilePath import Exception (ghandle, SomeException(..)) import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan, Type) import Prelude import qualified GHC as G import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Doc import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.Gap import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.SrcUtils import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils (mkRevRedirMapFunc) import Language.Haskell.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 (showDoc 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 => FilePath -- ^ A target file. -> Int -- ^ Line number. -> Int -- ^ Column number. -> GhcModT m String types file lineNo colNo = ghandle handler $ runGmlT' [Left file] deferErrors $ withInteractiveContext $ do crdl <- cradle modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl file) srcSpanTypes <- getSrcSpanType 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" $ showDoc ex return [] getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)] getSrcSpanType modSum lineNo colNo = do p <- G.parseModule modSum tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id] es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id] ps = listifySpans tcs (lineNo, colNo) :: [LPat Id] bts <- mapM (getType tcm) bs ets <- mapM (getType tcm) es pts <- mapM (getType tcm) ps return $ catMaybes $ concat [ets, bts, pts] ghc-mod-5.4.0.0/Language/Haskell/GhcMod/Lang.hs0000644000000000000000000000045312576164335017064 0ustar0000000000000000module Language.Haskell.GhcMod.Lang where import DynFlags (supportedLanguagesAndExtensions) import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Monad -- | Listing language extensions. languages :: IOish m => GhcModT m String languages = convert' supportedLanguagesAndExtensions ghc-mod-5.4.0.0/Language/Haskell/GhcMod/Lint.hs0000644000000000000000000000176412576164335017117 0ustar0000000000000000module Language.Haskell.GhcMod.Lint where import Exception (ghandle) import Control.Exception (SomeException(..)) import Language.Haskell.GhcMod.Logger (checkErrorPrefix) import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types import Language.Haskell.HLint (hlint) import Language.Haskell.GhcMod.Utils (withMappedFile) import Data.List (stripPrefix) -- | Checking syntax of a target file using hlint. -- Warnings and errors are returned. lint :: IOish m => FilePath -- ^ A target file. -> GhcModT m String lint file = do opt <- options withMappedFile file $ \tempfile -> liftIO (hlint $ tempfile : "--quiet" : optHlintOpts opt) >>= mapM (replaceFileName tempfile) >>= ghandle handler . pack where pack = convert' . map init -- init drops the last \n. handler (SomeException e) = return $ checkErrorPrefix ++ show e ++ "\n" replaceFileName fp s = return $ maybe (show s) (file++) $ stripPrefix fp (show s) ghc-mod-5.4.0.0/Language/Haskell/GhcMod/LightGhc.hs0000644000000000000000000000243512576164335017676 0ustar0000000000000000module Language.Haskell.GhcMod.LightGhc where 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 Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.DynFlags withLightHscEnv :: forall m a. IOish m => [GHCOption] -> (HscEnv -> m a) -> m a withLightHscEnv opts action = gbracket initEnv teardownEnv action where teardownEnv :: HscEnv -> m () teardownEnv env = liftIO $ do let dflags = hsc_dflags env cleanTempFiles dflags cleanTempDirs dflags initEnv :: m HscEnv initEnv = liftIO $ do initStaticOpts settings <- initSysTools (Just libdir) dflags <- initDynFlags (defaultDynFlags settings) env <- newHscEnv dflags dflags' <- runLightGhc env $ do -- HomeModuleGraph and probably all other clients get into all sorts of -- trouble if the package state isn't initialized here _ <- setSessionDynFlags =<< addCmdOpts opts =<< getSessionDynFlags getSessionDynFlags newHscEnv dflags' runLightGhc :: HscEnv -> LightGhc a -> IO a runLightGhc env action = do renv <- newIORef env flip runReaderT renv $ unLightGhc action ghc-mod-5.4.0.0/Language/Haskell/GhcMod/Logger.hs0000644000000000000000000001250612576164335017424 0ustar0000000000000000module Language.Haskell.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, asks, runReader) import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) import System.FilePath (normalise) import Text.PrettyPrint import ErrUtils import GHC import HscTypes import Outputable import qualified GHC as G import Bag import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Doc (showPage) import Language.Haskell.GhcMod.DynFlags (withDynFlags) import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Utils (mkRevRedirMapFunc) import qualified Language.Haskell.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 -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO () appendLogRef rfm df (LogRef ref) _ sev src st msg = do modifyIORef ref update where gpe = GmPprEnv { gpeDynFlags = df , gpeMapFile = rfm } l = runReader (ppMsg st src sev msg) gpe 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 [render $ 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 dflags <- asks gpeDynFlags let unqual = errMsgContext err st = Gap.mkErrStyle' dflags unqual let ext = showPage dflags st (errMsgExtraInfo err) m <- ppMsg st spn SevError msg return $ m ++ (if null ext then "" else "\n" ++ ext) where spn = Gap.errorMsgSpan err msg = errMsgShortDoc err ppMsg :: PprStyle -> SrcSpan -> Severity -> SDoc -> GmPprEnvM String ppMsg st spn sev msg = do dflags <- asks gpeDynFlags let cts = showPage dflags st msg prefix <- ppMsgPrefix spn sev cts return $ prefix ++ cts ppMsgPrefix :: SrcSpan -> Severity -> String -> GmPprEnvM String ppMsgPrefix spn sev cts = do dflags <- asks gpeDynFlags mr <- asks gpeMapFile let defaultPrefix | Gap.isDumpSplices dflags = "" | otherwise = checkErrorPrefix return $ fromMaybe defaultPrefix $ do (line,col,_,_) <- Gap.getSrcSpan spn file <- mr <$> normalise <$> Gap.getSrcFile spn let severityCaption = Gap.showSeverityCaption sev pref0 | or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes) = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" | otherwise = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption return pref0 checkErrorPrefix :: String checkErrorPrefix = "Dummy:0:0:Error:" warningAsErrorPrefixes :: [String] warningAsErrorPrefixes = ["Couldn't match expected type" , "Couldn't match type" , "No instance for"] ghc-mod-5.4.0.0/Language/Haskell/GhcMod/Logging.hs0000644000000000000000000000621212576164335017570 0ustar0000000000000000-- ghc-mod: Making Haskell development *more* fun -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Language.Haskell.GhcMod.Logging ( module Language.Haskell.GhcMod.Logging , module Language.Haskell.GhcMod.Pretty , GmLogLevel(..) , module Text.PrettyPrint , module Data.Monoid ) where import Control.Applicative hiding (empty) import Control.Monad import Control.Monad.Trans.Class import Data.List import Data.Char import Data.Monoid import Data.Maybe import System.IO import System.FilePath import Text.PrettyPrint hiding (style, (<>)) import Prelude import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Pretty import Language.Haskell.GhcMod.Output gmSetLogLevel :: GmLog m => GmLogLevel -> m () gmSetLogLevel level = gmlJournal $ GhcModLog (Just level) (Last Nothing) [] gmSetDumpLevel :: GmLog m => Bool -> m () gmSetDumpLevel level = gmlJournal $ GhcModLog Nothing (Last (Just level)) [] increaseLogLevel :: GmLogLevel -> GmLogLevel increaseLogLevel l | l == maxBound = l increaseLogLevel l = succ l decreaseLogLevel :: GmLogLevel -> GmLogLevel decreaseLogLevel l | l == minBound = l decreaseLogLevel l = pred l -- | -- >>> Just GmDebug <= Nothing -- False -- >>> Just GmException <= Just GmDebug -- True -- >>> Just GmDebug <= Just GmException -- False gmLog :: (MonadIO m, GmLog m, 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 = gmLogLevelDoc level <+>: sep [loc, doc] msg = dropWhileEnd isSpace $ gmRenderDoc msgDoc when (level <= level') $ gmErrStrLn msg gmlJournal (GhcModLog Nothing (Last Nothing) [(level, loc', msgDoc)]) gmVomit :: (MonadIO m, GmLog m, 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.4.0.0/Language/Haskell/GhcMod/Modules.hs0000644000000000000000000000163512576164335017616 0ustar0000000000000000module Language.Haskell.GhcMod.Modules (modules) where import Control.Arrow import Data.List import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Gap ( listVisibleModuleNames , lookupModulePackageInAllPackages ) import qualified GHC as G ---------------------------------------------------------------- -- | Listing installed modules. modules :: (IOish m, Gm m) => m String modules = do Options { optDetailed } <- options df <- runGmPkgGhc G.getSessionDynFlags let mns = listVisibleModuleNames df pmnss = map (first moduleNameString) $ zip mns (modulePkg df `map` mns) convert' $ nub [ if optDetailed then pkg ++ " " ++ mn else mn | (mn, pkgs) <- pmnss, pkg <- pkgs ] where modulePkg df = lookupModulePackageInAllPackages df ghc-mod-5.4.0.0/Language/Haskell/GhcMod/Monad.hs0000644000000000000000000001062212576164335017240 0ustar0000000000000000-- ghc-mod: Making Haskell development *more* fun -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE CPP #-} module Language.Haskell.GhcMod.Monad ( runGmOutT , runGmOutT' , runGhcModT , runGhcModT' , hoistGhcModT , runGmlT , runGmlT' , runGmlTWith , runGmPkgGhc , withGhcModEnv , withGhcModEnv' , module Language.Haskell.GhcMod.Monad.Types ) where import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.Target import Language.Haskell.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 Prelude withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> (GhcModEnv -> m a) -> m a withGhcModEnv = withGhcModEnv' withCradle where withCradle dir = gbracket (findCradle' dir) (liftIO . cleanupCradle) withGhcModEnv' :: (IOish m, GmOut m) => (FilePath -> (Cradle -> m a) -> m a) -> FilePath -> Options -> (GhcModEnv -> m a) -> m a withGhcModEnv' withCradle dir opts f = withCradle dir $ \crdl -> withCradleRootDir crdl $ f $ GhcModEnv opts crdl where withCradleRootDir (cradleRootDir -> projdir) a = do cdir <- liftIO $ getCurrentDirectory eq <- liftIO $ pathsEqual projdir cdir if not eq then throw $ GMEWrongWorkingDirectory projdir cdir else a pathsEqual a b = do ca <- canonicalizePath a cb <- canonicalizePath b return $ ca == cb 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' :: IOish m => GhcModOut -> GmOutT m a -> m a runGmOutT' gmo ma = flip runReaderT gmo $ unGmOutT ma -- | Run a @GhcModT m@ computation. runGhcModT :: (IOish m, GmOut m) => Options -> GhcModT m a -> m (Either GhcModError a, GhcModLog) runGhcModT opt action = liftIO (getCurrentDirectory >>= canonicalizePath) >>= \dir' -> do runGmOutT opt $ withGhcModEnv dir' opt $ \env -> first (fst <$>) <$> runGhcModT' env defaultGhcModState (gmSetLogLevel (ooptLogLevel $ optOutput opt) >> 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.4.0.0/Language/Haskell/GhcMod/Output.hs0000644000000000000000000001524212576164335017505 0ustar0000000000000000-- ghc-mod: Making Haskell development *more* fun -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -- Derived from process:System.Process -- Copyright (c) The University of Glasgow 2004-2008 module Language.Haskell.GhcMod.Output ( gmPutStr , gmErrStr , gmPutStrLn , gmErrStrLn , gmPutStrIO , gmErrStrIO , gmReadProcess , stdoutGateway , flushStdoutGateway ) where import Data.List 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 Language.Haskell.GhcMod.Types hiding (LineSeparator, MonadIO(..)) import Language.Haskell.GhcMod.Monad.Types hiding (MonadIO(..)) 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 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 => m (FilePath -> [String] -> String -> IO String) readProcessStderrChan = do (_, e :: String -> IO ()) <- outputFns return $ readProcessStderrChan' e readProcessStderrChan' :: (String -> IO ()) -> FilePath -> [String] -> String -> IO String readProcessStderrChan' pute = go pute where go :: (String -> IO ()) -> FilePath -> [String] -> String -> IO String go putErr exe args input = do let cp = (proc exe args) { std_out = CreatePipe , std_err = CreatePipe , std_in = CreatePipe } (Just i, Just o, Just e, h) <- createProcess cp _ <- forkIO $ reader e output <- hGetContents o withForkWait (evaluate $ rnf output) $ \waitOut -> do -- now write any input unless (null input) $ ignoreSEx $ hPutStr i input -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE ignoreSEx $ hClose i -- wait on the output waitOut hClose o res <- waitForProcess h case res of ExitFailure rv -> 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.4.0.0/Language/Haskell/GhcMod/PathsAndFiles.hs0000644000000000000000000001765612576164335020705 0ustar0000000000000000-- ghc-mod: Making Haskell development *more* fun -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . module Language.Haskell.GhcMod.PathsAndFiles ( module Language.Haskell.GhcMod.PathsAndFiles , module Language.Haskell.GhcMod.Caching ) where import Config (cProjectVersion) import Control.Arrow (second) import Control.Applicative import Control.Exception as E import Control.Monad 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 Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Caching import qualified Language.Haskell.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 newtype UnString = UnString { unString :: String } instance Show UnString where show = unString instance Read UnString where readsPrec _ = \str -> [(UnString str, "")] -- | @findCabalFiles dir@. Searches for a @.cabal@ files in @dir@'s parent -- directories. The first parent directory containing more than one cabal file -- is assumed to be the project directory. If only one cabal file exists in this -- directory it is returned otherwise @findCabalFiles@ throws 'GMENoCabalFile' -- or 'GMETooManyCabalFiles' findCabalFile :: FilePath -> IO (Maybe FilePath) findCabalFile dir = do -- List of directories and all cabal file candidates dcs <- findFileInParentsP isCabalFile dir :: IO ([(DirPath, [FileName])]) let css = uncurry appendDir `map` dcs :: [[FilePath]] case find (not . null) css of Nothing -> return Nothing Just cfs@(_:_:_) -> throw $ GMETooManyCabalFiles cfs Just (a:_) -> return (Just a) Just [] -> error "findCabalFile" where appendDir :: DirPath -> [FileName] -> [FilePath] appendDir d fs = (d ) `map` fs findStackConfigFile :: FilePath -> IO (Maybe FilePath) findStackConfigFile dir = do fs <- map (second listToMaybe) <$> findFileInParentsP (=="stack.yaml") dir case find (isJust . snd) fs of Nothing -> return Nothing Just (d, Just a) -> return $ Just $ d a Just (_, Nothing) -> error "findStackConfigFile" -- | 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 dir@ Look for files satisfying @p@ in @dir@ and all -- it's parent directories. findFileInParentsP :: (FilePath -> Bool) -> FilePath -> IO [(DirPath, [FileName])] findFileInParentsP p dir' = U.makeAbsolute' dir' >>= \dir -> getFilesP p `zipMapM` parents dir -- | @getFilesP p dir@. Find all __files__ satisfying @p@ in @.cabal@ in @dir@. getFilesP :: (FilePath -> Bool) -> DirPath -> IO [FileName] getFilesP p dir = filterM p' =<< getDirectoryContents dir where p' fn = do (p fn && ) <$> doesFileExist (dir fn) findCabalSandboxDir :: FilePath -> IO (Maybe FilePath) findCabalSandboxDir dir = do dss <- findFileInParentsP isSandboxConfig dir return $ case find (not . null . snd) $ dss of Just (sbDir, _:_) -> Just sbDir _ -> Nothing where isSandboxConfig = (==sandboxConfigFileName) zipMapM :: Monad m => (a -> m c) -> [a] -> m [(a,c)] zipMapM f as = mapM (\a -> liftM ((,) a) $ f a) as -- | @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 = "build/autogen/cabal_macros.h" ghcSandboxPkgDbDir :: String -> String ghcSandboxPkgDbDir buildPlatf = do buildPlatf ++ "-ghc-" ++ cProjectVersion ++ "-packages.conf.d" packageCache :: String packageCache = "package.cache" -- | Filename of the symbol table cache file. symbolCache :: Cradle -> FilePath symbolCache crdl = cradleTempDir crdl symbolCacheFile symbolCacheFile :: String symbolCacheFile = "ghc-mod.symbol-cache" resolvedComponentsCacheFile :: 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" -- | @findCustomPackageDbFile dir@. Searches for a @ghc-mod.package-db-stack@ file in @dir@. -- If it exists in the given directory it is returned otherwise @findCradleFile@ -- returns @Nothing@ findCustomPackageDbFile :: FilePath -> IO (Maybe FilePath) findCustomPackageDbFile directory = do let path = directory "ghc-mod.package-db-stack" mightExist path ghc-mod-5.4.0.0/Language/Haskell/GhcMod/PkgDoc.hs0000644000000000000000000000175712576164335017362 0ustar0000000000000000module Language.Haskell.GhcMod.PkgDoc (pkgDoc) where import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.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.4.0.0/Language/Haskell/GhcMod/Pretty.hs0000644000000000000000000000462712576164335017501 0ustar0000000000000000-- ghc-mod: Making Haskell development *more* fun -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . module Language.Haskell.GhcMod.Pretty where import Control.Arrow hiding ((<+>)) import Data.Char import Data.List import Distribution.Helper import Text.PrettyPrint import Language.Haskell.GhcMod.Types docStyle :: Style docStyle = style { ribbonsPerLine = 1.2 } gmRenderDoc :: Doc -> String gmRenderDoc = renderStyle docStyle gmComponentNameDoc :: ChComponentName -> Doc gmComponentNameDoc ChSetupHsName = text $ "Setup.hs" gmComponentNameDoc ChLibName = text $ "library" gmComponentNameDoc (ChExeName n) = text $ "exe:" ++ n gmComponentNameDoc (ChTestName n) = text $ "test:" ++ n gmComponentNameDoc (ChBenchName n) = text $ "bench:" ++ n gmLogLevelDoc :: GmLogLevel -> Doc gmLogLevelDoc GmSilent = error "GmSilent MUST not be used for log messages" gmLogLevelDoc GmPanic = text "PANIC" gmLogLevelDoc GmException = text "EXCEPTION" gmLogLevelDoc GmError = text "ERROR" gmLogLevelDoc GmWarning = text "Warning" gmLogLevelDoc GmInfo = text "info" gmLogLevelDoc GmDebug = text "DEBUG" gmLogLevelDoc GmVomit = text "VOMIT" infixl 6 <+>: (<+>:) :: Doc -> Doc -> Doc a <+>: b = (a <> colon) <+> b fnDoc :: FilePath -> Doc fnDoc = doubleQuotes . text showDoc :: Show a => a -> Doc showDoc = 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.4.0.0/Language/Haskell/GhcMod/Read.hs0000644000000000000000000001115012576164335017052 0ustar0000000000000000module Language.Haskell.GhcMod.Read where import Text.Read (readPrec_to_S, readPrec, minPrec) import qualified Text.ParserCombinators.ReadP as P import Text.ParserCombinators.ReadPrec (lift) -- This library (libraries/base) is derived from code from several -- sources: -- * Code from the GHC project which is largely (c) The University of -- Glasgow, and distributable under a BSD-style license (see below), -- * Code from the Haskell 98 Report which is (c) Simon Peyton Jones -- and freely redistributable (but see the full license for -- restrictions). -- * Code from the Haskell Foreign Function Interface specification, -- which is (c) Manuel M. T. Chakravarty and freely redistributable -- (but see the full license for restrictions). -- The full text of these licenses is reproduced below. All of the -- licenses are BSD-style or compatible. -- ----------------------------------------------------------------------------- -- The Glasgow Haskell Compiler License -- Copyright 2004, The University Court of the University of Glasgow. -- All rights reserved. -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are met: -- - Redistributions of source code must retain the above copyright notice, -- this list of conditions and the following disclaimer. -- - Redistributions in binary form must reproduce the above copyright notice, -- this list of conditions and the following disclaimer in the documentation -- and/or other materials provided with the distribution. -- - Neither name of the University nor the names of its contributors may be -- used to endorse or promote products derived from this software without -- specific prior written permission. -- THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF -- GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, -- INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -- FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -- UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE -- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH -- DAMAGE. -- ----------------------------------------------------------------------------- -- Code derived from the document "Report on the Programming Language -- Haskell 98", is distributed under the following license: -- Copyright (c) 2002 Simon Peyton Jones -- The authors intend this Report to belong to the entire Haskell -- community, and so we grant permission to copy and distribute it for -- any purpose, provided that it is reproduced in its entirety, -- including this Notice. Modified versions of this Report may also be -- copied and distributed for any purpose, provided that the modified -- version is clearly presented as such, and that it does not claim to -- be a definition of the Haskell 98 Language. -- ----------------------------------------------------------------------------- -- Code derived from the document "The Haskell 98 Foreign Function -- Interface, An Addendum to the Haskell 98 Report" is distributed under -- the following license: -- Copyright (c) 2002 Manuel M. T. Chakravarty -- The authors intend this Report to belong to the entire Haskell -- community, and so we grant permission to copy and distribute it for -- any purpose, provided that it is reproduced in its entirety, -- including this Notice. Modified versions of this Report may also be -- copied and distributed for any purpose, provided that the modified -- version is clearly presented as such, and that it does not claim to -- be a definition of the Haskell 98 Foreign Function Interface. -- ----------------------------------------------------------------------------- readEither :: Read a => String -> Either String a readEither s = case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of [x] -> Right x [] -> Left "Prelude.read: no parse" _ -> Left "Prelude.read: ambiguous parse" where read' = do x <- readPrec lift P.skipSpaces return x readMaybe :: Read a => String -> Maybe a readMaybe s = case readEither s of Left _ -> Nothing Right a -> Just a ghc-mod-5.4.0.0/Language/Haskell/GhcMod/SrcUtils.hs0000644000000000000000000000665512576164335017765 0ustar0000000000000000{-# LANGUAGE TupleSections, FlexibleInstances, Rank2Types #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Haskell.GhcMod.SrcUtils where import Control.Applicative import CoreUtils (exprType) import Data.Generics import Data.Maybe (fromMaybe) import Data.Ord as O import GHC (LHsExpr, LPat, Id, DynFlags, SrcSpan, Type, Located, ParsedSource, RenamedSource, TypecheckedSource, GenLocated(L)) import qualified GHC as G import GHC.SYB.Utils (Stage(..), everythingStaged) import GhcMonad import qualified Language.Haskell.Exts.Annotated as HE import Language.Haskell.GhcMod.Doc import Language.Haskell.GhcMod.Gap import qualified Language.Haskell.GhcMod.Gap as Gap import OccName (OccName) import Outputable (PprStyle) import TcHsSyn (hsPatType) import Prelude ---------------------------------------------------------------- instance HasType (LHsExpr Id) where getType tcm e = do hs_env <- G.getSession mbe <- liftIO $ Gap.deSugar tcm e hs_env return $ (G.getLoc e, ) <$> CoreUtils.exprType <$> mbe instance HasType (LPat Id) where getType _ (G.L spn pat) = return $ Just (spn, hsPatType pat) ---------------------------------------------------------------- listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a] listifySpans tcs lc = listifyStaged TypeChecker p tcs where p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc listifyParsedSpans :: Typeable a => ParsedSource -> (Int, Int) -> [Located a] listifyParsedSpans pcs lc = listifyStaged Parser p pcs where p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc listifyRenamedSpans :: Typeable a => RenamedSource -> (Int, Int) -> [Located a] listifyRenamedSpans pcs lc = listifyStaged Renamer p pcs where p (L spn _) = G.isGoodSrcSpan spn && spn `G.spans` lc listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r] listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x])) cmp :: SrcSpan -> SrcSpan -> Ordering cmp a b | a `G.isSubspanOf` b = O.LT | b `G.isSubspanOf` a = O.GT | otherwise = O.EQ toTup :: DynFlags -> PprStyle -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String) toTup dflag style (spn, typ) = (fourInts spn, pretty dflag style typ) fourInts :: SrcSpan -> (Int,Int,Int,Int) fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan fourIntsHE :: HE.SrcSpan -> (Int,Int,Int,Int) fourIntsHE loc = ( HE.srcSpanStartLine loc, HE.srcSpanStartColumn loc , HE.srcSpanEndLine loc, HE.srcSpanEndColumn loc) -- Check whether (line,col) is inside a given SrcSpanInfo typeSigInRangeHE :: Int -> Int -> HE.Decl HE.SrcSpanInfo -> Bool typeSigInRangeHE lineNo colNo (HE.TypeSig (HE.SrcSpanInfo s _) _ _) = HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo) typeSigInRangeHE lineNo colNo (HE.TypeFamDecl (HE.SrcSpanInfo s _) _ _) = HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo) typeSigInRangeHE lineNo colNo (HE.DataFamDecl (HE.SrcSpanInfo s _) _ _ _) = HE.srcSpanStart s <= (lineNo, colNo) && HE.srcSpanEnd s >= (lineNo, colNo) typeSigInRangeHE _ _ _= False pretty :: DynFlags -> PprStyle -> Type -> String pretty dflag style = showOneLine dflag style . Gap.typeForUser 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.4.0.0/Language/Haskell/GhcMod/Stack.hs0000644000000000000000000000652312576164335017254 0ustar0000000000000000-- ghc-mod: Making Haskell development *more* fun -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . module Language.Haskell.GhcMod.Stack where 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 Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Output import qualified Language.Haskell.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) => FilePath -> m (Maybe StackEnv) getStackEnv projdir = U.withDirectory_ projdir $ runMaybeT $ do env <- map (liToTup . splitOn ": ") . lines <$> readStack ["path"] let look k = fromJust $ 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) => [String] -> MaybeT m String readStack args = do stack <- MaybeT $ liftIO $ findExecutable "stack" readProc <- lift gmReadProcess lift $ flip gcatch (\(e :: IOError) -> exToErr e) $ do liftIO $ evaluate =<< readProc stack args "" where exToErr = throw . GMEStackBootstrap . GMEString . show ghc-mod-5.4.0.0/Language/Haskell/GhcMod/Target.hs0000644000000000000000000004321112576164335017430 0ustar0000000000000000-- ghc-mod: Making Haskell development *more* fun -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE CPP, ViewPatterns, NamedFieldPuns, RankNTypes #-} module Language.Haskell.GhcMod.Target where import Control.Arrow import Control.Applicative import Control.Category ((.)) import GHC import GHC.Paths (libdir) import SysTools import DynFlags import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.CabalHelper import Language.Haskell.GhcMod.HomeModuleGraph import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils as U import Language.Haskell.GhcMod.FileMapping import Language.Haskell.GhcMod.LightGhc import Language.Haskell.GhcMod.CustomPackageDb import Language.Haskell.GhcMod.Output 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] -> (DynFlags -> Ghc DynFlags) -> GhcModT m () initSession opts mdf = do s <- gmsGet case gmGhcSession s of Just GmGhcSession {..} | gmgsOptions /= opts-> do gmLog GmDebug "initSession" $ text "Flags changed, creating new session" putNewSession s Just _ -> return () Nothing -> do gmLog GmDebug "initSession" $ text "Session not initialized, creating new one" putNewSession s where putNewSession s = do rghc <- (liftIO . newIORef =<< newSession =<< cradle) gmsPut s { gmGhcSession = Just $ GmGhcSession opts rghc } newSession Cradle { cradleTempDir } = liftIO $ do runGhc (Just libdir) $ do let setDf df = setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df) _ <- setSessionDynFlags =<< setDf =<< getSessionDynFlags getSession -- | Drop the currently active GHC session, the next that requires a GHC session -- will initialize a new one. dropSession :: IOish m => GhcModT m () dropSession = do s <- gmsGet case gmGhcSession s of Just (GmGhcSession _opts ref) -> do -- TODO: This is still not enough, there seem to still be references to -- GHC's state around afterwards. liftIO $ writeIORef ref (error "HscEnv: session was dropped") -- Not available on ghc<7.8; didn't really help anyways -- liftIO $ setUnsafeGlobalDynFlags (error "DynFlags: session was dropped") gmsPut s { gmGhcSession = Nothing } Nothing -> return () runGmlT :: IOish m => [Either FilePath ModuleName] -> GmlT m a -> GhcModT m a runGmlT fns action = runGmlT' fns return action runGmlT' :: IOish m => [Either FilePath ModuleName] -> (DynFlags -> Ghc DynFlags) -> GmlT m a -> GhcModT m a runGmlT' fns mdf action = runGmlTWith fns mdf id action runGmlTWith :: IOish m => [Either FilePath ModuleName] -> (DynFlags -> Ghc DynFlags) -> (GmlT m a -> GmlT m b) -> GmlT m a -> GhcModT m b runGmlTWith efnmns' mdf wrapper action = do crdl <- cradle Options { 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' $ setModeSimple >>> 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 $ fromJust $ Map.lookup (head cns) mcs else do when noCandidates $ throwError $ GMECabalCompAssignment mdlcs let cn = pickComponent candidates return $ gmcGhcOpts $ fromJust $ Map.lookup cn mcs resolvedComponentsCache :: IOish m => 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 iifsM = invalidatingInputFiles tcfs mums :: Maybe [Either FilePath ModuleName] mums = case iifsM of Nothing -> Nothing Just iifs -> let filterOutSetupCfg = filter (/= cradleRootDir setupConfigPath distdir) changedFiles = filterOutSetupCfg iifs in if null changedFiles then Nothing else Just $ map Left changedFiles setupChanged = maybe False (elem $ cradleRootDir setupConfigPath distdir) iifsM case (setupChanged, ma) of (False, Just mcs) -> gmsGet >>= \s -> gmsPut s { gmComponents = mcs } _ -> return () let mdesc (Left f) = "file:" ++ f mdesc (Right mn) = "module:" ++ moduleNameString mn changed = map (text . mdesc) $ Foldable.concat mums changedDoc | [] <- changed = text "none" | otherwise = sep changed gmLog GmDebug "resolvedComponentsCache" $ text "files changed" <+>: changedDoc mcs <- resolveGmComponents mums comps return (setupConfigPath 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 :: (Applicative m, IOish 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 he file from `main-is:` is always module `Main` and let -- ghc do the warning about it. Right now we run that module through -- resolveModule like any other resolveChEntrypoints :: FilePath -> ChEntrypoint -> IO [CompilationUnit] resolveChEntrypoints _ (ChLibEntrypoint em om) = return $ map (Right . chModToMod) (em ++ om) resolveChEntrypoints _ (ChExeEntrypoint main om) = return $ [Left main] ++ map (Right . chModToMod) om resolveChEntrypoints srcDir ChSetupEntrypoint = do shs <- doesFileExist (srcDir "Setup.hs") slhs <- doesFileExist (srcDir "Setup.lhs") return $ case (shs, slhs) of (True, _) -> [Left "Setup.hs"] (_, True) -> [Left "Setup.lhs"] (False, False) -> [] chModToMod :: ChModuleName -> ModuleName chModToMod (ChModuleName mn) = mkModuleName mn resolveModule :: (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) $ Monoid.mempty $+$ (vcat $ map text errs) return Nothing -- TODO: should expose these errors otherwise -- modules with preprocessor/parse errors are -- going to be missing Right mmn -> return $ Just $ case mmn of Nothing -> mkMainModulePath fn Just mn -> ModulePath mn fn where -- needed for ghc 7.4 findFile' dirs file = getFirst . mconcat <$> mapM (fmap First . mightExist . (file)) dirs -- fileModuleName fn (dir:dirs) -- | makeRelative dir fn /= fn type CompilationUnit = Either FilePath ModuleName resolveGmComponents :: (IOish m, Gm m) => Maybe [CompilationUnit] -- ^ Updated modules -> [GmComponent 'GMCRaw (Set ModulePath)] -> m (Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath))) resolveGmComponents mumns cs = do s <- gmsGet m' <- foldrM' (gmComponents s) cs $ \c m -> do case Map.lookup (gmcName c) m of Nothing -> insertUpdated m c Just c' -> if same gmcRawEntrypoints c c' && same gmcGhcSrcOpts c c' then return m else insertUpdated m c gmsPut s { gmComponents = m' } return m' where foldrM' b fa f = foldrM f b fa insertUpdated m c = do rc <- resolveGmComponent mumns c return $ Map.insert (gmcName rc) rc m same :: Eq b => (forall t a. GmComponent t a -> b) -> GmComponent u c -> GmComponent v d -> Bool same f a b = (f a) == (f b) -- | Set the files as targets and load them. 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 mode <- getCompilerMode if mode == Intelligent then loadTargets' Intelligent else do mdls <- depanal [] False let fallback = needsFallback mdls if fallback then do resetTargets targets setIntelligent gmLog GmInfo "loadTargets" $ text "Target needs interpeter, switching to LinkInMemory/HscInterpreted. Perfectly normal if anything is using TemplateHaskell, QuasiQuotes or PatternSynonyms." loadTargets' Intelligent else loadTargets' Simple 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 loadTargets' Simple = do void $ load LoadAllTargets mapM_ (parseModule >=> typecheckModule >=> desugarModule) =<< getModuleGraph loadTargets' Intelligent = do df <- getSessionDynFlags void $ setSessionDynFlags (setModeIntelligent df) void $ load LoadAllTargets resetTargets targets' = do setTargets [] void $ load LoadAllTargets setTargets targets' setIntelligent = do newdf <- setModeIntelligent <$> getSessionDynFlags void $ setSessionDynFlags newdf setCompilerMode Intelligent showTargetId (Target (TargetModule s) _ _) = moduleNameString s showTargetId (Target (TargetFile s _) _ _) = s needsFallback :: ModuleGraph -> Bool needsFallback = any $ \ms -> let df = ms_hspp_opts ms in Opt_TemplateHaskell `xopt` df || Opt_QuasiQuotes `xopt` df #if __GLASGOW_HASKELL__ >= 708 || (Opt_PatternSynonyms `xopt` df) #endif cabalResolvedComponents :: (IOish m) => GhcModT m (Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath))) cabalResolvedComponents = do crdl@(Cradle{..}) <- cradle comps <- mapM (resolveEntrypoint crdl) =<< getComponents cached cradleRootDir (resolvedComponentsCache cradleDistDir) comps ghc-mod-5.4.0.0/Language/Haskell/GhcMod/Types.hs0000644000000000000000000003026312576164335017311 0ustar0000000000000000{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, RankNTypes, StandaloneDeriving, DefaultSignatures, FlexibleInstances, TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-} module Language.Haskell.GhcMod.Types ( module Language.Haskell.GhcMod.Types , ModuleName , mkModuleName , moduleNameString ) where import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Error (Error(..)) import qualified Control.Monad.IO.Class as MTL import Control.Exception (Exception) import Control.Applicative import Control.Concurrent import Control.Monad import Data.Serialize import Data.Version import Data.List (intercalate) import 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 PackageConfig (PackageConfig) import GHC.Generics import Text.PrettyPrint (Doc) import Prelude import Language.Haskell.GhcMod.Caching.Types -- | A constraint alias (-XConstraintKinds) to make functions dealing with -- 'GhcModT' somewhat cleaner. -- -- 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 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] -- | If 'True', 'browse' also returns operators. , optOperators :: Bool -- | If 'True', 'browse' also returns types. , optDetailed :: Bool -- | If 'True', 'browse' will return fully qualified name , optQualified :: Bool , optHlintOpts :: [String] , optFileMappings :: [(FilePath, Maybe FilePath)] } 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 = [] , optOperators = False , optDetailed = False , optQualified = False , optHlintOpts = [] , optFileMappings = [] } ---------------------------------------------------------------- data Project = CabalProject | SandboxProject | PlainProject | StackProject StackEnv deriving (Eq, Show) 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) -- | 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) 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 { gmgsOptions :: ![GHCOption], gmgsSession :: !(IORef HscEnv) } data GhcModCaches = GhcModCaches { gmcPackageDbStack :: CacheContents ChCacheData [GhcPkgDb] , gmcMergedPkgOptions :: CacheContents ChCacheData [GHCOption] , gmcComponents :: CacheContents ChCacheData [GmComponent 'GMCRaw ChEntrypoint] , gmcResolvedComponents :: CacheContents [GmComponent 'GMCRaw (Set.Set ModulePath)] (Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath))) } data GhcModState = GhcModState { gmGhcSession :: !(Maybe GmGhcSession) , gmComponents :: !(Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath))) , gmCompilerMode :: !CompilerMode , gmCaches :: !GhcModCaches , gmMMappedFiles :: !FileMappingMap } data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read) defaultGhcModState :: GhcModState defaultGhcModState = GhcModState n Map.empty Simple (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 Serialize GhcPkgDb -- | A single GHC command line option. type GHCOption = String -- | An include directory for modules. type IncludeDir = FilePath -- | A package name. type PackageBaseName = String -- | A package version. type PackageVersion = String -- | A package id. type PackageId = String -- | A package's name, verson and id. type Package = (PackageBaseName, PackageVersion, PackageId) pkgName :: Package -> PackageBaseName pkgName (n, _, _) = n pkgVer :: Package -> PackageVersion pkgVer (_, v, _) = v pkgId :: Package -> PackageId pkgId (_, _, i) = i showPkg :: Package -> String showPkg (n, v, _) = intercalate "-" [n, v] showPkgId :: Package -> String showPkgId (n, v, i) = intercalate "-" [n, v, i] -- | Haskell expression. newtype Expression = Expression { getExpression :: String } deriving (Show, Eq, Ord) -- | Module name. newtype ModuleString = ModuleString { getModuleString :: String } deriving (Show, Read, Eq, Ord) data GmLogLevel = GmSilent | GmPanic | GmException | GmError | GmWarning | GmInfo | GmDebug | GmVomit deriving (Eq, Ord, Enum, Bounded, Show, Read) -- | Collection of packages type PkgDb = (Map Package PackageConfig) data GmModuleGraph = GmModuleGraph { gmgGraph :: Map ModulePath (Set ModulePath) } deriving (Eq, Ord, Show, Read, Generic, Typeable) instance Serialize GmModuleGraph where put GmModuleGraph {..} = put (mpim, graph) where mpim :: Map ModulePath Integer mpim = Map.fromList $ Map.keys gmgGraph `zip` [0..] graph :: Map Integer (Set Integer) graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph mpToInt :: ModulePath -> Integer mpToInt mp = fromJust $ Map.lookup mp mpim get = do (mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get let impm = swapMap mpim intToMp i = fromJust $ Map.lookup i impm mpGraph :: Map ModulePath (Set ModulePath) mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph return $ GmModuleGraph mpGraph where swapMap :: (Ord k, Ord v) => Map k v -> Map v k swapMap = Map.fromList . map (\(x, y) -> (y, x)) . Map.toList instance Monoid GmModuleGraph where mempty = GmModuleGraph mempty mappend (GmModuleGraph a) (GmModuleGraph a') = GmModuleGraph (Map.unionWith Set.union a a') data GmComponentType = GMCRaw | GMCResolved data GmComponent (t :: GmComponentType) eps = GmComponent { gmcHomeModuleGraph :: GmModuleGraph , gmcName :: ChComponentName , gmcGhcOpts :: [GHCOption] , gmcGhcPkgOpts :: [GHCOption] , gmcGhcSrcOpts :: [GHCOption] , gmcGhcLangOpts :: [GHCOption] , gmcRawEntrypoints :: ChEntrypoint , gmcEntrypoints :: eps , gmcSourceDirs :: [FilePath] } deriving (Eq, Ord, Show, Read, Generic, Functor) instance Serialize eps => Serialize (GmComponent t eps) data ModulePath = ModulePath { mpModule :: ModuleName, mpPath :: FilePath } deriving (Eq, Ord, Show, Read, Generic, Typeable) instance Serialize ModulePath instance Serialize ModuleName where get = mkModuleName <$> get put mn = put (moduleNameString mn) instance Show ModuleName where show mn = "ModuleName " ++ show (moduleNameString mn) instance Read ModuleName where readsPrec d = readParen (d > app_prec) (\r' -> [ (mkModuleName m, t) | ("ModuleName", s) <- lex r' , (m, t) <- readsPrec (app_prec + 1) s ]) where app_prec = 10 data GhcModError = GMENoMsg -- ^ Unknown error | GMEString String -- ^ Some Error with a message. These are produced mostly by -- 'fail' calls on GhcModT. | GMECabalConfigure GhcModError -- ^ Configuring a cabal project failed. | 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. | GMEWrongWorkingDirectory FilePath FilePath deriving (Eq,Show,Typeable) instance Error GhcModError where noMsg = GMENoMsg strMsg = GMEString instance Exception GhcModError deriving instance Generic Version instance Serialize Version instance Serialize CabalHelper.Programs instance Serialize ChModuleName instance Serialize ChComponentName instance Serialize ChEntrypoint mkLabel ''GhcModCaches mkLabel ''GhcModState mkLabel ''Options mkLabel ''OutputOpts mkLabel ''Programs ghc-mod-5.4.0.0/Language/Haskell/GhcMod/Utils.hs0000644000000000000000000001663512576164335017314 0ustar0000000000000000-- ghc-mod: Making Haskell development *more* fun -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE CPP #-} {-# LANGUAGE DoAndIfThenElse #-} module Language.Haskell.GhcMod.Utils ( module Language.Haskell.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 Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Types import Language.Haskell.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) 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 (uniqTempDirName dir) =<< 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 #ifndef SPEC ghcModExecutable = do dir <- takeDirectory <$> getExecutablePath' return $ (if dir == "." then "" else dir) "ghc-mod" #else ghcModExecutable = fmap ( "dist/build/ghc-mod/ghc-mod") getCurrentDirectory #endif findLibexecExe :: String -> IO FilePath findLibexecExe "cabal-helper-wrapper" = do libexecdir <- getLibexecDir let exeName = "cabal-helper-wrapper" exe = libexecdir exeName exists <- doesFileExist exe if exists then return exe else do mdir <- tryFindGhcModTreeDataDir case mdir of Nothing -> error $ libexecNotExitsError exeName libexecdir Just dir -> return $ dir "dist" "build" exeName exeName findLibexecExe exe = error $ "findLibexecExe: Unknown executable: " ++ exe libexecNotExitsError :: String -> FilePath -> String libexecNotExitsError exe dir = printf ( "Could not find $libexecdir/%s\n" ++"\n" ++"If you are a developer set the environment variable `ghc_mod_libexecdir'\n" ++"to override $libexecdir[1] the following will work in the ghc-mod tree:\n" ++"\n" ++" $ export ghc_mod_libexecdir=$PWD/dist/build/%s\n" ++"\n" ++"[1]: %s\n" ++"\n" ++"If you don't know what I'm talking about something went wrong with your\n" ++"installation. Please report this problem here:\n" ++"\n" ++" https://github.com/kazu-yamamoto/ghc-mod/issues") exe exe dir tryFindGhcModTreeLibexecDir :: IO (Maybe FilePath) tryFindGhcModTreeLibexecDir = do exe <- getExecutablePath' dir <- case takeFileName exe of "ghc" -> getCurrentDirectory -- we're probably in ghci; try CWD _ -> return $ (!!4) $ iterate takeDirectory exe exists <- doesFileExist $ dir "ghc-mod.cabal" return $ if exists then Just dir else Nothing tryFindGhcModTreeDataDir :: IO (Maybe FilePath) tryFindGhcModTreeDataDir = do dir <- (!!4) . iterate takeDirectory <$> getExecutablePath' exists <- doesFileExist $ dir "ghc-mod.cabal" return $ if exists then Just dir else Nothing readLibExecProcess' :: (MonadIO m, ExceptionMonad m) => String -> [String] -> m String readLibExecProcess' cmd args = do exe <- liftIO $ findLibexecExe cmd liftIO $ readProcess exe args "" getExecutablePath' :: IO FilePath #if __GLASGOW_HASKELL__ >= 706 getExecutablePath' = getExecutablePath #else getExecutablePath' = getProgName #endif canonFilePath :: FilePath -> IO FilePath canonFilePath f = do p <- canonicalizePath f e <- doesFileExist p when (not e) $ error $ "canonFilePath: not a file: " ++ p return p 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.4.0.0/Language/Haskell/GhcMod/World.hs0000644000000000000000000000341512576164335017273 0ustar0000000000000000module Language.Haskell.GhcMod.World where import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Utils import Control.Applicative 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 , worldSymbolCache :: Maybe TimedFile } deriving (Eq, Show) 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) mSymbolCache <- liftIO $ timeMaybe (symbolCache crdl) return World { worldPackageCaches = pkgCaches , worldCabalFile = mCabalFile , worldCabalConfig = mCabalConfig , worldCabalSandboxConfig = mCabalSandboxConfig , worldSymbolCache = mSymbolCache } 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.4.0.0/Language/Haskell/GhcMod/Caching/0000755000000000000000000000000012576164335017201 5ustar0000000000000000ghc-mod-5.4.0.0/Language/Haskell/GhcMod/Caching/Types.hs0000644000000000000000000000307512576164335020646 0ustar0000000000000000module Language.Haskell.GhcMod.Caching.Types where import Utils import Data.Label import Data.Version import Distribution.Helper type CacheContents d a = Maybe ([FilePath], d, a) type CacheLens s d a = s :-> CacheContents d a data Cached m s d a = Cached { cacheFile :: FilePath, cacheLens :: Maybe (CacheLens s d a), cachedAction :: TimedCacheFiles -> d -> Maybe a -> m ([FilePath], a) -- ^ @cachedAction tcf data ma@ -- -- * @tcf@: Input file timestamps. Not technically necessary, just an -- optimizazion when knowing which input files changed can make updating the -- cache faster -- -- * @data@: Arbitrary static input data to cache action. Can be used to -- invalidate the cache using something other than file timestamps -- i.e. environment tool version numbers -- -- * @ma@: Cached data if it existed -- -- Returns: -- -- * @fst@: Input files used in generating the cache -- -- * @snd@: Cache data, will be stored alongside the static input data in the -- 'cacheFile' -- -- The cached action, will only run if one of the following is true: -- -- * 'cacheFile' doesn\'t exist yet -- * 'cacheFile' exists and 'inputData' changed -- * any files returned by the cached action changed } data TimedCacheFiles = TimedCacheFiles { tcCacheFile :: Maybe TimedFile, -- ^ 'cacheFile' timestamp tcFiles :: [TimedFile] -- ^ Timestamped files returned by the cached action } deriving (Eq, Ord, Show) type ChCacheData = (Programs, FilePath, (Version, [Char])) ghc-mod-5.4.0.0/Language/Haskell/GhcMod/Monad/0000755000000000000000000000000012576164335016703 5ustar0000000000000000ghc-mod-5.4.0.0/Language/Haskell/GhcMod/Monad/Types.hs0000644000000000000000000004202212576164335020343 0ustar0000000000000000-- ghc-mod: Making Haskell development *more* fun -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-} {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-} {-# LANGUAGE TypeFamilies, UndecidableInstances, BangPatterns #-} {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Haskell.GhcMod.Monad.Types ( -- * Monad Types GhcModT , GmOutT(..) , GmT(..) , GmlT(..) , LightGhc(..) , GmGhc , IOish -- * Environment, state and logging , GhcModEnv(..) , GhcModState(..) , GhcModCaches(..) , defaultGhcModState , GmGhcSession(..) , GmComponent(..) , CompilerMode(..) -- * Accessing 'GhcModEnv', 'GhcModState' and 'GhcModLog' , GmLogLevel(..) , GhcModLog(..) , GhcModError(..) , Gm , GmEnv(..) , GmState(..) , GmLog(..) , GmOut(..) , cradle , options , outputOpts , withOptions , getCompilerMode , setCompilerMode , getMMappedFiles , setMMappedFiles , addMMappedFile , delMMappedFile , lookupMMappedFile , getMMappedFilePaths -- * Re-exporting convenient stuff , MonadIO , liftIO , gmlGetSession , gmlSetSession ) where -- MonadUtils of GHC 7.6 or earlier defines its own MonadIO. -- RWST does not automatically become an instance of MonadIO. -- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class. -- So, RWST automatically becomes an instance of #if __GLASGOW_HASKELL__ < 708 -- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different -- classes before ghc 7.8 #define DIFFERENT_MONADIO 1 -- RWST doen't have a MonadIO instance before ghc 7.8 #define MONADIO_INSTANCES 1 #endif import Language.Haskell.GhcMod.Types import GHC import DynFlags import Exception import HscTypes import Control.Applicative import Control.Monad import Control.Monad.Reader (ReaderT(..)) import Control.Monad.Error (ErrorT(..), MonadError(..)) import Control.Monad.State.Strict (StateT(..)) import Control.Monad.Trans.Journal (JournalT) import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Base (MonadBase(..), liftBase) import Control.Monad.Trans.Control import Control.Monad.Reader.Class import Control.Monad.Writer.Class import Control.Monad.State.Class (MonadState(..)) import Control.Monad.Journal.Class (MonadJournal(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Error (Error(..)) import qualified Control.Monad.IO.Class as MTL #if DIFFERENT_MONADIO import Data.Monoid (Monoid) #endif import qualified Data.Map as M import Data.Maybe import Data.Monoid import Data.IORef import Prelude import qualified MonadUtils as GHC (MonadIO(..)) type GhcModT m = GmT (GmOutT m) newtype GmOutT m a = GmOutT { unGmOutT :: ReaderT GhcModOut m a } deriving ( Functor , Applicative , Alternative , Monad , MonadPlus , MonadTrans , MTL.MonadIO #if DIFFERENT_MONADIO , GHC.MonadIO #endif , GmLog ) newtype GmT m a = GmT { unGmT :: StateT GhcModState (ErrorT GhcModError (JournalT GhcModLog (ReaderT GhcModEnv m) ) ) a } deriving ( Functor , Applicative , Alternative , Monad , MonadPlus , MTL.MonadIO #if DIFFERENT_MONADIO , GHC.MonadIO #endif , MonadError GhcModError ) newtype GmlT m a = GmlT { unGmlT :: GhcModT m a } deriving ( Functor , Applicative , Alternative , Monad , MonadPlus , MTL.MonadIO #if DIFFERENT_MONADIO , GHC.MonadIO #endif , MonadError GhcModError , GmEnv , GmState , GmLog ) newtype LightGhc a = LightGhc { unLightGhc :: ReaderT (IORef HscEnv) IO a } deriving ( Functor , Applicative , Monad , MTL.MonadIO #if DIFFERENT_MONADIO , GHC.MonadIO #endif ) -------------------------------------------------- -- 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 #endif instance MonadIO IO where liftIO = id instance MonadIO m => MonadIO (ReaderT x m) where liftIO = MTL.liftIO instance MonadIO m => MonadIO (StateT x m) where liftIO = MTL.liftIO instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where liftIO = MTL.liftIO instance MonadIO m => MonadIO (JournalT x m) where liftIO = MTL.liftIO instance MonadIO m => MonadIO (MaybeT m) where liftIO = MTL.liftIO instance MonadIOC m => MonadIO (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 instance MonadTrans GmT where lift = GmT . lift . lift . lift . lift instance MonadTrans GmlT where lift = GmlT . lift . lift -------------------------------------------------- -- Gm Classes type Gm m = (GmEnv m, GmState m, GmLog m, GmOut m) -- GmEnv ----------------------------------------- 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)) -- GmState --------------------------------------- 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 -- GmLog ----------------------------------------- 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 -- GmOut ----------------------------------------- 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 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 forall r m. MonadReader r m => MonadReader r (GmT m) where local f ma = gmLiftWithInner (\run -> local f (run ma)) ask = gmLiftInner ask instance (Monoid w, MonadWriter w m) => MonadWriter w (GmT m) where tell = gmLiftInner . tell listen ma = liftWith (\run -> listen (run ma)) >>= \(sta, w) -> flip (,) w `liftM` restoreT (return sta) pass maww = maww >>= gmLiftInner . pass . return instance MonadState s m => MonadState s (GmT m) where get = GmT $ lift $ lift $ lift get put = GmT . lift . lift . lift . put state = GmT . lift . lift . lift . state -------------------------------------------------- -- monad-control instances -- 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 -- GmT ------------------------------------------ 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 #-} 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 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 gmlGetSession :: (MonadIO m, MonadBaseControl IO m) => GmlT m HscEnv gmlGetSession = do ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet GHC.liftIO $ readIORef ref gmlSetSession :: (MonadIO m, MonadBaseControl IO m) => HscEnv -> GmlT m () gmlSetSession a = do ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet GHC.liftIO $ flip writeIORef a ref instance GhcMonad LightGhc where getSession = (GHC.liftIO . readIORef) =<< LightGhc ask setSession a = (GHC.liftIO . flip writeIORef a) =<< LightGhc ask #if __GLASGOW_HASKELL__ >= 706 instance (MonadIO m, MonadBaseControl IO m) => HasDynFlags (GmlT m) where getDynFlags = hsc_dflags <$> getSession instance HasDynFlags LightGhc where getDynFlags = hsc_dflags <$> getSession #endif instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (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 ---------------------------------------------------------------- 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 getCompilerMode :: GmState m => m CompilerMode getCompilerMode = gmCompilerMode `liftM` gmsGet setCompilerMode :: GmState m => CompilerMode -> m () setCompilerMode mode = (\s -> gmsPut s { gmCompilerMode = mode } ) =<< gmsGet 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.4.0.0/src/0000755000000000000000000000000012576164335012165 5ustar0000000000000000ghc-mod-5.4.0.0/src/GHCModi.hs0000644000000000000000000000304612576164335013736 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} -- | 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.4.0.0/src/Misc.hs0000644000000000000000000000304212576164335013413 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, CPP #-} module Misc ( SymDbReq , newSymDbReq , getDb , checkDb ) where import Control.Concurrent.Async (Async, async, wait) import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Prelude import Language.Haskell.GhcMod import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO) import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Monad ---------------------------------------------------------------- type SymDbReqAction = (Either GhcModError SymbolDb, GhcModLog) data SymDbReq = SymDbReq (IORef (Async SymDbReqAction)) (IO SymDbReqAction) newSymDbReq :: Options -> GhcModOut -> FilePath -> IO SymDbReq newSymDbReq opt gmo tmpdir = do let act = runGmOutT' gmo $ runGhcModT opt $ loadSymbolDb tmpdir req <- async act ref <- newIORef req return $ SymDbReq ref act getDb :: IOish m => SymDbReq -> GhcModT m SymbolDb getDb (SymDbReq ref _) = do req <- liftIO $ readIORef ref -- 'wait' really waits for the asynchronous action at the fist time. -- Then it reads a cached value from the second time. hoistGhcModT =<< liftIO (wait req) checkDb :: IOish m => SymDbReq -> SymbolDb -> GhcModT m SymbolDb checkDb (SymDbReq ref act) db = do outdated <- isOutdated db if outdated then do -- async and wait here is unnecessary because this is essentially -- synchronous. But Async can be used a cache. req <- liftIO $ async act liftIO $ writeIORef ref req hoistGhcModT =<< liftIO (wait req) else return db ghc-mod-5.4.0.0/src/GHCMod.hs0000644000000000000000000006115612576164335013573 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} module Main where import Config (cProjectVersion) import Control.Category import Control.Applicative import Control.Arrow import Control.Monad import Data.Typeable (Typeable) import Data.Version (showVersion) import Data.Label import Data.List import Data.List.Split import Data.Char (isSpace) import Data.Maybe import Exception import Language.Haskell.GhcMod import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO) import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Monad import Paths_ghc_mod import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..)) import qualified System.Console.GetOpt as O import System.FilePath (()) import System.Directory (setCurrentDirectory, getAppUserDataDirectory, removeDirectoryRecursive) import System.Environment (getArgs) import System.IO import System.Exit import Text.PrettyPrint import Prelude hiding ((.)) import Misc progVersion :: String -> String progVersion pf = "ghc-mod"++pf++" version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n" ghcModVersion :: String ghcModVersion = progVersion "" ghcModiVersion :: String ghcModiVersion = progVersion "i" optionUsage :: (String -> String) -> [OptDescr a] -> [String] optionUsage indent opts = concatMap optUsage opts where optUsage (Option so lo dsc udsc) = [ concat $ intersperse ", " $ addLabel `map` allFlags , indent $ udsc , "" ] where allFlags = shortFlags ++ longFlags shortFlags = (('-':) . return) `map` so :: [String] longFlags = ("--"++) `map` lo addLabel f@('-':'-':_) = f ++ flagLabel "=" addLabel f@('-':_) = f ++ flagLabel " " addLabel _ = undefined flagLabel s = case dsc of NoArg _ -> "" ReqArg _ label -> s ++ label OptArg _ label -> s ++ "["++label++"]" -- TODO: Generate the stuff below automatically usage :: String usage = "Usage: ghc-mod [OPTIONS...] COMMAND [CMD_ARGS...] \n\ \*Global Options (OPTIONS)*\n\ \ Global options can be specified before and after the command and\n\ \ interspersed with command specific options\n\ \\n" ++ (unlines $ indent <$> optionUsage indent globalArgSpec) ++ "*Commands*\n\ \ - version\n\ \ Print the version of the program.\n\ \\n\ \ - help\n\ \ Print this help message.\n\ \\n\ \ - list [FLAGS...] | modules [FLAGS...]\n\ \ List all visible modules.\n\ \ Flags:\n\ \ -d\n\ \ Print package modules belong to.\n\ \\n\ \ - lang\n\ \ List all known GHC language extensions.\n\ \\n\ \ - flag\n\ \ List GHC -f flags.\n\ \\n\ \ - browse [FLAGS...] [PACKAGE:]MODULE...\n\ \ List symbols in a module.\n\ \ Flags:\n\ \ -o\n\ \ Also print operators.\n\ \ -d\n\ \ Print symbols with accompanying signatures.\n\ \ -q\n\ \ Qualify symbols.\n\ \\n\ \ - check FILE...\n\ \ Load the given files using GHC and report errors/warnings, but\n\ \ don't produce output files.\n\ \\n\ \ - expand FILE...\n\ \ Like `check' but also pass `-ddump-splices' to GHC.\n\ \\n\ \ - info FILE [MODULE] EXPR\n\ \ Look up an identifier in the context of FILE (like ghci's `:info')\n\ \ MODULE is completely ignored and only allowed for backwards\n\ \ compatibility.\n\ \\n\ \ - type FILE [MODULE] LINE COL\n\ \ Get the type of the expression under (LINE,COL).\n\ \\n\ \ - split FILE [MODULE] LINE COL\n\ \ Split a function case by examining a type's constructors.\n\ \\n\ \ For example given the following code snippet:\n\ \\n\ \ f :: [a] -> a\n\ \ f x = _body\n\ \\n\ \ would be replaced by:\n\ \\n\ \ f :: [a] -> a\n\ \ f [] = _body\n\ \ f (x:xs) = _body\n\ \\n\ \ (See https://github.com/kazu-yamamoto/ghc-mod/pull/274)\n\ \\n\ \ - sig FILE MODULE LINE COL\n\ \ Generate initial code given a signature.\n\ \\n\ \ For example when (LINE,COL) is on the signature in the following\n\ \ code snippet:\n\ \\n\ \ func :: [a] -> Maybe b -> (a -> b) -> (a,b)\n\ \\n\ \ ghc-mod would add the following on the next line:\n\ \\n\ \ func x y z f = _func_body\n\ \\n\ \ (See: https://github.com/kazu-yamamoto/ghc-mod/pull/274)\n\ \\n\ \ - refine FILE MODULE LINE COL EXPR\n\ \ Refine the typed hole at (LINE,COL) given EXPR.\n\ \\n\ \ For example if EXPR is `filter', which has type `(a -> Bool) -> [a]\n\ \ -> [a]' and (LINE,COL) is on the hole `_body' in the following\n\ \ code snippet:\n\ \\n\ \ filterNothing :: [Maybe a] -> [a]\n\ \ filterNothing xs = _body\n\ \\n\ \ ghc-mod changes the code to get a value of type `[a]', which\n\ \ results in:\n\ \\n\ \ filterNothing xs = filter _body_1 _body_2\n\ \\n\ \ (See also: https://github.com/kazu-yamamoto/ghc-mod/issues/311)\n\ \\n\ \ - auto FILE MODULE LINE COL\n\ \ Try to automatically fill the contents of a hole.\n\ \\n\ \ - find SYMBOL\n\ \ List all modules that define SYMBOL.\n\ \\n\ \ - lint FILE\n\ \ Check files using `hlint'.\n\ \ Flags:\n\ \ -h\n\ \ Option to be passed to hlint.\n\ \\n\ \ - root\n\ \ Try to find the project directory. For Cabal projects this is the\n\ \ directory containing the cabal file, for projects that use a cabal\n\ \ sandbox but have no cabal file this is the directory containing the\n\ \ cabal.sandbox.config file and otherwise this is the current\n\ \ directory.\n\ \\n\ \ - doc MODULE\n\ \ Try finding the html documentation directory for the given MODULE.\n\ \\n\ \ - debug\n\ \ Print debugging information. Please include the output in any bug\n\ \ reports you submit.\n\ \\n\ \ - debugComponent [MODULE_OR_FILE...]\n\ \ Debugging information related to cabal component resolution.\n\ \\n\ \ - boot\n\ \ Internal command used by the emacs frontend.\n\ \\n\ \ - legacy-interactive\n\ \ ghc-modi compatibility mode.\n" where indent = (" "++) cmdUsage :: String -> String -> String cmdUsage cmd realUsage = let -- Find command head a = dropWhile (not . isCmdHead) $ lines realUsage -- Take til the end of the current command block b = flip takeWhile a $ \l -> all isSpace l || (isIndented l && (isCmdHead l || isNotCmdHead l)) -- Drop extra newline from the end c = dropWhileEnd (all isSpace) b isIndented = (" " `isPrefixOf`) isNotCmdHead = ( not . (" - " `isPrefixOf`)) containsAnyCmdHead s = ((" - ") `isInfixOf` s) containsCurrCmdHead s = ((" - " ++ cmd) `isInfixOf` s) isCmdHead s = containsAnyCmdHead s && or [ containsCurrCmdHead s , any (cmd `isPrefixOf`) (splitOn " | " s) ] unindent (' ':' ':' ':' ':l) = l unindent l = l in unlines $ unindent <$> c ghcModStyle :: Style ghcModStyle = style { lineLength = 80, ribbonsPerLine = 1.2 } ---------------------------------------------------------------- option :: [Char] -> [String] -> String -> ArgDescr a -> OptDescr a option s l udsc dsc = Option s l dsc udsc reqArg :: String -> (String -> a) -> ArgDescr a reqArg udsc dsc = ReqArg dsc udsc optArg :: String -> (Maybe String -> a) -> ArgDescr a optArg udsc dsc = OptArg dsc udsc intToLogLevel :: Int -> GmLogLevel intToLogLevel = toEnum globalArgSpec :: [OptDescr (Options -> Either [String] Options)] globalArgSpec = [ option "v" ["verbose"] "Increase or set log level. (0-7)" $ optArg "LEVEL" $ \ml o -> Right $ case ml of Nothing -> modify (lOoptLogLevel . lOptOutput) increaseLogLevel o Just l -> set (lOoptLogLevel . lOptOutput) (toEnum $ min 7 $ read l) o , option "s" [] "Be silent, set log level to 0" $ NoArg $ \o -> Right $ set (lOoptLogLevel . lOptOutput) (toEnum 0) o , option "l" ["tolisp"] "Format output as an S-Expression" $ NoArg $ \o -> Right $ set (lOoptStyle . lOptOutput) LispStyle o , option "b" ["boundary", "line-seperator"] "Output line separator"$ reqArg "SEP" $ \s o -> Right $ set (lOoptLineSeparator . lOptOutput) (LineSeparator s) o , option "" ["line-prefix"] "Output line separator"$ reqArg "OUT,ERR" $ \s o -> let [out, err] = splitOn "," s in Right $ set (lOoptLinePrefix . lOptOutput) (Just (out, err)) o , option "g" ["ghcOpt", "ghc-option"] "Option to be passed to GHC" $ reqArg "OPT" $ \g o -> Right $ o { optGhcUserOptions = g : optGhcUserOptions o } {- File map docs: CLI options: * `--map-file "file1.hs=file2.hs"` 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"` can be used to tell ghc-mod that it should take source code for `file.hs` from stdin. File end marker is `\EOT\n`, i.e. `\x04\x0A`. `file.hs` may or may not exist, and should be either full path, or relative to project root. Interactive commands: * `map-file file.hs` -- tells ghc-modi to read `file.hs` source from stdin. Works the same as second form of `--map-file` CLI option. * `unmap-file file.hs` -- unloads previously mapped file, so that it's no longer mapped. `file.hs` can be full path or relative to project root, either will work. Exposed functions: * `loadMappedFile :: FilePath -> FilePath -> GhcModT m ()` -- 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. * `loadMappedFileSource :: FilePath -> String -> GhcModT m ()` -- maps `FilePath`, given as first argument to have source as given by second argument. Works exactly the same as second form of `--map-file` CLI option, sans reading from stdin. * `unloadMappedFile :: FilePath -> GhcModT m ()` -- unmaps `FilePath`, given as first argument, and removes any temporary files created when file was mapped. Works exactly the same as `unmap-file` interactive command -} , option "" ["map-file"] "Redirect one file to another, --map-file \"file1.hs=file2.hs\"" $ reqArg "OPT" $ \g o -> let m = case second (drop 1) $ span (/='=') g of (s,"") -> (s, Nothing) (f,t) -> (f, Just t) in Right $ o { optFileMappings = m : optFileMappings o } , option "" ["with-ghc"] "GHC executable to use" $ reqArg "PATH" $ \p o -> Right $ set (lGhcProgram . lOptPrograms) p o , option "" ["with-ghc-pkg"] "ghc-pkg executable to use (only needed when guessing from GHC path fails)" $ reqArg "PATH" $ \p o -> Right $ set (lGhcPkgProgram . lOptPrograms) p o , option "" ["with-cabal"] "cabal-install executable to use" $ reqArg "PATH" $ \p o -> Right $ set (lCabalProgram . lOptPrograms) p o , option "" ["with-stack"] "stack executable to use" $ reqArg "PATH" $ \p o -> Right $ set (lStackProgram . lOptPrograms) p o , option "" ["version"] "print version information" $ NoArg $ \_ -> Left ["version"] , option "" ["help"] "print this help message" $ NoArg $ \_ -> Left ["help"] ] parseGlobalArgs :: [String] -> Either InvalidCommandLine (Options, [String]) parseGlobalArgs argv = case O.getOpt' RequireOrder globalArgSpec argv of (o,r,u,[]) -> case foldr (=<<) (Right defaultOptions) o of Right o' -> Right (o', u ++ r) Left c -> Right (defaultOptions, c) (_,_,u,e) -> Left $ InvalidCommandLine $ Right $ "Parsing command line options failed: " ++ concat (e ++ map errUnrec u) where errUnrec :: String -> String errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n" parseCommandArgs :: [OptDescr (Options -> Either [String] Options)] -> [String] -> Options -> (Options, [String]) parseCommandArgs spec argv opts = case O.getOpt RequireOrder (globalArgSpec ++ spec) argv of (o,r,[]) -> case foldr (=<<) (Right opts) o of Right o' -> (o', r) Left c -> (defaultOptions, c) (_,_,errs) -> fatalError $ "Parsing command options failed: " ++ concat errs ---------------------------------------------------------------- data CmdError = UnknownCommand String | NoSuchFileError String | LibraryError GhcModError deriving (Show, Typeable) instance Exception CmdError data InteractiveOptions = InteractiveOptions { ghcModExtensions :: Bool } handler :: IOish m => GhcModT m a -> GhcModT m a handler = flip gcatches $ [ GHandler $ \(FatalError msg) -> exitError msg , GHandler $ \e@(ExitSuccess) -> throw e , GHandler $ \e@(ExitFailure _) -> throw e , GHandler $ \(InvalidCommandLine e) -> do case e of Left cmd -> exitError $ "Usage for `"++cmd++"' command:\n\n" ++ (cmdUsage cmd usage) ++ "\n" ++ "ghc-mod: Invalid command line form." Right msg -> exitError $ "ghc-mod: " ++ msg , GHandler $ \(SomeException e) -> exitError $ "ghc-mod: " ++ show e ] main :: IO () main = do hSetEncoding stdout utf8 args <- getArgs case parseGlobalArgs args of Left e -> throw e Right res@(globalOptions,_) -> catches (progMain res) [ Handler $ \(e :: GhcModError) -> runGmOutT globalOptions $ exitError $ renderStyle ghcModStyle (gmeDoc e) ] progMain :: (Options,[String]) -> IO () progMain (globalOptions,cmdArgs) = runGmOutT globalOptions $ case globalCommands cmdArgs of Just s -> gmPutStr s Nothing -> wrapGhcCommands globalOptions cmdArgs globalCommands :: [String] -> Maybe String globalCommands (cmd:_) | cmd == "help" = Just usage | cmd == "version" = Just ghcModVersion globalCommands _ = Nothing -- ghc-modi legacyInteractive :: IOish m => GhcModT m () legacyInteractive = do opt <- options prepareCabalHelper tmpdir <- cradleTempDir <$> cradle gmo <- gmoAsk symdbreq <- liftIO $ newSymDbReq opt gmo tmpdir world <- getCurrentWorld legacyInteractiveLoop symdbreq world bug :: IOish m => String -> GhcModT m () bug msg = do gmPutStrLn $ notGood $ "BUG: " ++ msg liftIO exitFailure notGood :: String -> String notGood msg = "NG " ++ escapeNewlines msg escapeNewlines :: String -> String escapeNewlines = replace "\n" "\\n" . replace "\\n" "\\\\n" replace :: String -> String -> String -> String replace needle replacement = intercalate replacement . splitOn needle legacyInteractiveLoop :: IOish m => SymDbReq -> World -> GhcModT m () legacyInteractiveLoop symdbreq 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 $ do dropSession let (cmd':args') = split (keepDelimsR $ condense $ whenElt isSpace) cmdArg arg = concat args' cmd = dropWhileEnd isSpace cmd' args = dropWhileEnd isSpace `map` args' res <- flip gcatches interactiveHandlers $ case dropWhileEnd isSpace cmd of "check" -> checkSyntaxCmd [arg] "lint" -> lintCmd [arg] "find" -> do db <- getDb symdbreq >>= checkDb symdbreq lookupSymbol arg db "info" -> infoCmd [head args, concat $ tail args'] "type" -> typesCmd args "split" -> splitsCmd args "sig" -> sigCmd args "auto" -> autoCmd args "refine" -> refineCmd args "boot" -> bootCmd [] "browse" -> browseCmd args "map-file" -> liftIO getFileSourceFromStdin >>= loadMappedFileSource arg >> return "" "unmap-file" -> unloadMappedFile arg >> return "" "quit" -> liftIO $ exitSuccess "" -> liftIO $ exitSuccess _ -> fatalError $ "unknown command: `" ++ cmd ++ "'" gmPutStr res >> gmPutStrLn "OK" >> liftIO (hFlush stdout) legacyInteractiveLoop symdbreq world' where interactiveHandlers = [ GHandler $ \e@(FatalError _) -> throw e , GHandler $ \e@(ExitSuccess) -> throw e , GHandler $ \e@(ExitFailure _) -> throw e , GHandler $ \(SomeException e) -> gmErrStrLn (show e) >> return "" ] getFileSourceFromStdin :: IO String getFileSourceFromStdin = do let loop' acc = do line <- getLine if not (null line) && last line == '\EOT' then return $ acc ++ init line else loop' (acc++line++"\n") loop' "" -- Someone please already rewrite the cmdline parsing code *weep* :'( wrapGhcCommands :: (IOish m, GmOut m) => Options -> [String] -> m () wrapGhcCommands _opts [] = fatalError "No command given (try --help)" wrapGhcCommands _opts ("root":_) = gmPutStr =<< rootInfo wrapGhcCommands opts args = do handleGmError $ runGhcModT opts $ handler $ do forM_ (reverse $ optFileMappings opts) $ uncurry loadMMappedFiles ghcCommands args where handleGmError action = do (e, _l) <- liftIO . evaluate =<< action case e of Right _ -> return () Left ed -> exitError $ renderStyle ghcModStyle (gmeDoc ed) loadMMappedFiles from (Just to) = loadMappedFile from to loadMMappedFiles from (Nothing) = do src <- liftIO getFileSourceFromStdin loadMappedFileSource from src ghcCommands :: IOish m => [String] -> GhcModT m () ghcCommands [] = fatalError "No command given (try --help)" ghcCommands (cmd:args) = gmPutStr =<< action args where action = case cmd of _ | cmd == "list" || cmd == "modules" -> modulesCmd "lang" -> languagesCmd "flag" -> flagsCmd "browse" -> browseCmd "check" -> checkSyntaxCmd "expand" -> expandTemplateCmd "debug" -> debugInfoCmd "debug-component" -> componentInfoCmd "info" -> infoCmd "type" -> typesCmd "split" -> splitsCmd "sig" -> sigCmd "refine" -> refineCmd "auto" -> autoCmd "find" -> findSymbolCmd "lint" -> lintCmd -- "root" -> rootInfoCmd "doc" -> pkgDocCmd "dumpsym" -> dumpSymbolCmd "boot" -> bootCmd "legacy-interactive" -> legacyInteractiveCmd -- "nuke-caches" -> nukeCachesCmd _ -> fatalError $ "unknown command: `" ++ cmd ++ "'" newtype FatalError = FatalError String deriving (Show, Typeable) instance Exception FatalError 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 fatalError :: String -> a fatalError s = throw $ FatalError $ "ghc-mod: " ++ s withParseCmd :: IOish m => [OptDescr (Options -> Either [String] Options)] -> ([String] -> GhcModT m a) -> [String] -> GhcModT m a withParseCmd spec action args = do (opts', rest) <- parseCommandArgs spec args <$> options withOptions (const opts') $ action rest withParseCmd' :: (IOish m, ExceptionMonad m) => String -> [OptDescr (Options -> Either [String] Options)] -> ([String] -> GhcModT m a) -> [String] -> GhcModT m a withParseCmd' cmd spec action args = catchArgs cmd $ withParseCmd spec action args catchArgs :: (Monad m, ExceptionMonad m) => String -> m a -> m a catchArgs cmd action = action `gcatch` \(PatternMatchFail _) -> throw $ InvalidCommandLine (Left cmd) modulesCmd, languagesCmd, flagsCmd, browseCmd, checkSyntaxCmd, expandTemplateCmd, debugInfoCmd, componentInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd, refineCmd, autoCmd, findSymbolCmd, lintCmd, pkgDocCmd, dumpSymbolCmd, bootCmd, legacyInteractiveCmd, nukeCachesCmd :: IOish m => [String] -> GhcModT m String modulesCmd = withParseCmd' "modules" s $ \[] -> modules where s = modulesArgSpec languagesCmd = withParseCmd' "lang" [] $ \[] -> languages flagsCmd = withParseCmd' "flag" [] $ \[] -> flags debugInfoCmd = withParseCmd' "debug" [] $ \[] -> debugInfo componentInfoCmd = withParseCmd' "debugComponent" [] $ \ts -> componentInfo ts -- internal bootCmd = withParseCmd' "boot" [] $ \[] -> boot nukeCachesCmd = withParseCmd' "nuke-caches" [] $ \[] -> nukeCaches >> return "" dumpSymbolCmd = withParseCmd' "dump" [] $ \[tmpdir] -> dumpSymbol tmpdir findSymbolCmd = withParseCmd' "find" [] $ \[sym] -> findSymbol sym pkgDocCmd = withParseCmd' "doc" [] $ \[mdl] -> pkgDoc mdl lintCmd = withParseCmd' "lint" s $ \[file] -> lint file where s = hlintArgSpec browseCmd = withParseCmd s $ \mdls -> concat <$> browse `mapM` mdls where s = browseArgSpec checkSyntaxCmd = withParseCmd [] $ checkAction checkSyntax expandTemplateCmd = withParseCmd [] $ checkAction expandTemplate typesCmd = withParseCmd [] $ locAction "type" types splitsCmd = withParseCmd [] $ locAction "split" splits sigCmd = withParseCmd [] $ locAction "sig" sig autoCmd = withParseCmd [] $ locAction "auto" auto refineCmd = withParseCmd [] $ locAction' "refine" refine infoCmd = withParseCmd [] $ action where action [file,_,expr] = info file $ Expression expr action [file,expr] = info file $ Expression expr action _ = throw $ InvalidCommandLine (Left "info") legacyInteractiveCmd = withParseCmd [] go where go [] = legacyInteractive >> return "" go ("help":[]) = return usage go ("version":[]) = return ghcModiVersion go _ = throw $ InvalidCommandLine (Left "legacy-interactive") checkAction :: ([t] -> a) -> [t] -> a checkAction _ [] = throw $ InvalidCommandLine (Right "No files given.") checkAction action files = action files locAction :: String -> (String -> Int -> Int -> a) -> [String] -> a locAction _ action [file,_,line,col] = action file (read line) (read col) locAction _ action [file, line,col] = action file (read line) (read col) locAction cmd _ _ = throw $ InvalidCommandLine (Left cmd) locAction' :: String -> (String -> Int -> Int -> Expression -> a) -> [String] -> a locAction' _ action [f,_,line,col,expr] = action f (read line) (read col) (Expression expr) locAction' _ action [f, line,col,expr] = action f (read line) (read col) (Expression expr) locAction' cmd _ _ = throw $ InvalidCommandLine (Left cmd) modulesArgSpec :: [OptDescr (Options -> Either [String] Options)] modulesArgSpec = [ option "d" ["detailed"] "Print package modules belong to." $ NoArg $ \o -> Right $ o { optDetailed = True } ] hlintArgSpec :: [OptDescr (Options -> Either [String] Options)] hlintArgSpec = [ option "h" ["hlintOpt"] "Option to be passed to hlint" $ reqArg "hlintOpt" $ \h o -> Right $ o { optHlintOpts = h : optHlintOpts o } ] browseArgSpec :: [OptDescr (Options -> Either [String] Options)] browseArgSpec = [ option "o" ["operators"] "Also print operators." $ NoArg $ \o -> Right $ o { optOperators = True } , option "d" ["detailed"] "Print symbols with accompanying signature." $ NoArg $ \o -> Right $ o { optDetailed = True } , option "q" ["qualified"] "Qualify symbols" $ NoArg $ \o -> Right $ o { optQualified = True } ] 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.4.0.0/test/0000755000000000000000000000000012576164335012355 5ustar0000000000000000ghc-mod-5.4.0.0/test/Main.hs0000644000000000000000000000414112576164335013575 0ustar0000000000000000{-# LANGUAGE CPP, ScopedTypeVariables #-} import Spec import Dir import Control.Exception as E import Control.Monad (void) import Data.List import Language.Haskell.GhcMod (debugInfo) import System.Process import Test.Hspec import TestUtils main :: IO () main = do let sandboxes = [ "test/data/cabal-project" , "test/data/check-packageid" , "test/data/duplicate-pkgver/" , "test/data/broken-cabal/" ] genSandboxCfg dir = withDirectory dir $ \cwdir -> do system ("sed 's|@CWD@|" ++ cwdir ++ "|g' cabal.sandbox.config.in > cabal.sandbox.config") pkgDirs = [ "test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d" , "test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d" , "test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"] genGhcPkgCache dir = system $ "ghc-pkg recache --force -f" ++ dir genSandboxCfg `mapM_` sandboxes genGhcPkgCache `mapM_` pkgDirs let caches = [ "setup-config" , "setup-config.ghc-mod.cabal-helper" , "setup-config.ghc-mod.cabal-components" , "setup-config.ghc-mod.resolved-components" , "setup-config.ghc-mod.package-options" , "setup-config.ghc-mod.package-db-stack" , "ghc-mod.cache" ] findExp = unwords $ intersperse "-o " $ concat [ stackWorkFindExp, cachesFindExp ] cachesFindExp = map ("-name "++) caches stackWorkFindExp = ["-name .stack-work -type d"] cleanCmd = "find test \\( "++ findExp ++" \\) -exec rm -r {} \\;" putStrLn $ "$ " ++ cleanCmd void $ system cleanCmd void $ system "cabal --version" void $ system "ghc --version" let stackDir = "test/data/stack-project" void $ withDirectory_ stackDir $ do -- void $ system "stack init --force" void $ system "stack setup" void $ system "stack build" (putStrLn =<< runD debugInfo) `E.catch` (\(_ :: E.SomeException) -> return () ) hspec spec ghc-mod-5.4.0.0/test/Dir.hs0000644000000000000000000000162412576164335013432 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.4.0.0/test/Spec.hs0000644000000000000000000000007412576164335013604 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-} ghc-mod-5.4.0.0/test/TestUtils.hs0000644000000000000000000000717112576164335014657 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} module TestUtils ( run , runD , runD' , runE , runNullLog , runGmOutDef , shouldReturnError , isPkgDbAt , isPkgConfDAt , module Language.Haskell.GhcMod.Monad , module Language.Haskell.GhcMod.Types ) where import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.Types import Control.Arrow import Control.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 withSpecCradle :: (IOish m, GmOut m) => FilePath -> (Cradle -> m a) -> m a withSpecCradle cradledir f = do gbracket (findSpecCradle cradledir) (liftIO . cleanupCradle) $ \crdl -> bracketWorkingDirectory (cradleRootDir crdl) $ f crdl bracketWorkingDirectory :: (ExceptionMonad m, MonadIO m) => FilePath -> m c -> m c bracketWorkingDirectory dir a = gbracket (swapWorkingDirectory dir) (liftIO . setCurrentDirectory) (const a) swapWorkingDirectory :: MonadIO m => FilePath -> m FilePath swapWorkingDirectory ndir = liftIO $ do odir <- getCurrentDirectory >>= canonicalizePath setCurrentDirectory $ ndir return odir 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) -- | 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 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.4.0.0/test/BrowseSpec.hs0000644000000000000000000000242012576164335014763 0ustar0000000000000000module BrowseSpec where import Control.Applicative import Language.Haskell.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 "Data.Map" syms `shouldContain` ["differenceWithKey"] describe "browse -d Data.Either" $ do it "contains functions (e.g. `either') including their type signature" $ do syms <- run defaultOptions { optDetailed = True } $ lines <$> browse "Data.Either" syms `shouldContain` ["either :: (a -> c) -> (b -> c) -> Either a b -> c"] it "contains type constructors (e.g. `Left') including their type signature" $ do syms <- run defaultOptions { optDetailed = True} $ lines <$> browse "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 "Data.Foo" syms `shouldContain` ["foo"] syms `shouldContain` ["fibonacci"] ghc-mod-5.4.0.0/test/CustomPackageDbSpec.hs0000644000000000000000000000223412576164335016521 0ustar0000000000000000module CustomPackageDbSpec where import Language.Haskell.GhcMod.CabalHelper import Language.Haskell.GhcMod.CustomPackageDb import Language.Haskell.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.4.0.0/test/CheckSpec.hs0000644000000000000000000000720312576164335014543 0ustar0000000000000000{-# LANGUAGE CPP #-} module CheckSpec where import Language.Haskell.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 `shouldBe` "DesugarWarnings.hs:4:9:Warning: Pattern match(es) are non-exhaustive\NULIn a case alternative: Patterns not matched: _ : _\n" #endif it "works with cabal builtin preprocessors" $ do withDirectory_ "test/data/cabal-preprocessors" $ do _ <- system "cabal clean" _ <- system "cabal build" res <- runD $ checkSyntax ["Main.hs"] res `shouldBe` "Preprocessed.hsc:3:1:Warning: Top-level binding with no type signature: warning :: ()\n" it "Uses the right qualification style" $ do withDirectory_ "test/data/nice-qualification" $ do res <- runD $ checkSyntax ["NiceQualification.hs"] #if __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.4.0.0/test/FlagSpec.hs0000644000000000000000000000051112576164335014372 0ustar0000000000000000module FlagSpec where import Control.Applicative import Language.Haskell.GhcMod import Test.Hspec import TestUtils import Prelude spec :: Spec spec = do describe "flags" $ do it "contains at least `-fno-warn-orphans'" $ do f <- runD $ lines <$> flags f `shouldContain` ["-fno-warn-orphans"] ghc-mod-5.4.0.0/test/InfoSpec.hs0000644000000000000000000000403712576164335014423 0ustar0000000000000000{-# LANGUAGE CPP #-} module InfoSpec where import Control.Applicative import Data.List (isPrefixOf) import Language.Haskell.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 "lib/Data/Foo.hs" 9 5 res `shouldBe` "9 5 11 40 \"Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n" it "works with a module using TemplateHaskell" $ do let tdir = "test/data/template-haskell" res <- runD' tdir $ types "Bar.hs" 5 1 res `shouldBe` unlines ["5 1 5 20 \"[Char]\""] it "works with a module that imports another module using TemplateHaskell" $ do let tdir = "test/data/template-haskell" res <- runD' tdir $ types "ImportsTH.hs" 3 8 res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""] describe "info" $ do it "works for non 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.4.0.0/test/LangSpec.hs0000644000000000000000000000052612576164335014410 0ustar0000000000000000module LangSpec where import Control.Applicative import Language.Haskell.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.4.0.0/test/LintSpec.hs0000644000000000000000000000116612576164335014436 0ustar0000000000000000module LintSpec where import Language.Haskell.GhcMod import Test.Hspec import TestUtils spec :: Spec spec = do describe "lint" $ do it "can detect a redundant import" $ do res <- runD $ lint "test/data/hlint/hlint.hs" res `shouldBe` "test/data/hlint/hlint.hs:4:8: Error: Redundant do\NULFound:\NUL do putStrLn \"Hello, world!\"\NULWhy not:\NUL putStrLn \"Hello, world!\"\n" context "when no suggestions are given" $ do it "doesn't output an empty line" $ do res <- runD $ lint "test/data/ghc-mod-check/lib/Data/Foo.hs" res `shouldBe` "" ghc-mod-5.4.0.0/test/ListSpec.hs0000644000000000000000000000050112576164335014433 0ustar0000000000000000module ListSpec where import Control.Applicative import Language.Haskell.GhcMod import Test.Hspec import TestUtils import Prelude spec :: Spec spec = do describe "modules" $ do it "contains at least `Data.Map'" $ do mdls <- runD $ lines <$> modules mdls `shouldContain` ["Data.Map"] ghc-mod-5.4.0.0/test/MonadSpec.hs0000644000000000000000000000107612576164335014566 0ustar0000000000000000module MonadSpec where import Test.Hspec import TestUtils import Control.Monad.Error.Class spec :: Spec spec = do describe "When using GhcModT in a do block" $ it "a pattern match failure causes a call to `fail` on ErrorT in the monad stack" $ do (a, _h) <- runGmOutDef $ runGhcModT defaultOptions $ do Just _ <- return Nothing return "hello" `catchError` (const $ fail "oh noes") a `shouldBe` (Left $ GMEString "oh noes") ghc-mod-5.4.0.0/test/PathsAndFilesSpec.hs0000644000000000000000000000361012576164335016211 0ustar0000000000000000module PathsAndFilesSpec where import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Cradle import qualified Language.Haskell.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 <- 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 <- 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.4.0.0/test/HomeModuleGraphSpec.hs0000644000000000000000000001420212576164335016543 0ustar0000000000000000-- ghc-mod: Making Haskell development *more* fun -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# LANGUAGE OverloadedStrings #-} module HomeModuleGraphSpec where import Language.Haskell.GhcMod.HomeModuleGraph import Language.Haskell.GhcMod.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.4.0.0/test/FileMappingSpec.hs0000644000000000000000000003150712576164335015725 0ustar0000000000000000module FileMappingSpec where import Language.Haskell.GhcMod.FileMapping import Language.Haskell.GhcMod.Utils (withMappedFile) import Test.Hspec import TestUtils import qualified Data.Map as M import Dir import System.IO.Temp import System.Directory import Language.Haskell.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 "File.hs" res `shouldBe` "File.hs:4: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" $ do res <- runD $ do loadMappedFileSource "File.hs" "func a b = (++) a b\n" lint "File.hs" res `shouldBe` "File.hs:1:1: Error: 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 "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 for in-memory files" $ do let tdir = "test/data/file-mapping" res <- runD' tdir $ do loadMappedFileSource "File.hs" "main = putStrLn \"Hello!\"" types "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 "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 "File.hs" res `shouldBe` "File.hs: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/preprocessor" $ do src <- readFile "File_Redir_Lint.hs" res <- runD $ do loadMappedFileSource "File.hs" src lint "File.hs" res `shouldBe` "File.hs:6:1: Error: 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 "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 "Bar.hs" 5 1 res `shouldBe` unlines ["5 1 5 20 \"[Char]\""] ghc-mod-5.4.0.0/test/doctests.hs0000644000000000000000000000111212576164335014534 0ustar0000000000000000{-# LANGUAGE CPP #-} module Main where import Test.DocTest main :: IO () main = doctest [ "-package", "ghc-" ++ VERSION_ghc , "-package", "transformers-" ++ VERSION_transformers , "-package", "mtl-" ++ VERSION_mtl , "-package", "directory-" ++ VERSION_directory , "-XScopedTypeVariables", "-XRecordWildCards", "-XNamedFieldPuns", "-XConstraintKinds", "-XFlexibleContexts", "-XDataKinds", "-XKindSignatures", "-XTypeOperators", "-XViewPatterns" , "-idist/build/autogen/" , "-optP-include" , "-optPdist/build/autogen/cabal_macros.h" , "Language/Haskell/GhcMod.hs" ] ghc-mod-5.4.0.0/test/data/0000755000000000000000000000000012576164335013266 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/annotations/0000755000000000000000000000000012576164335015623 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/annotations/With.hs0000644000000000000000000000016612576164335017075 0ustar0000000000000000module Main where {-# ANN module ["this", "can", "be", "anything"] #-} main :: IO () main = putStrLn "Hello world!" ghc-mod-5.4.0.0/test/data/broken-cabal/0000755000000000000000000000000012576164335015606 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/broken-cabal/broken.cabal0000644000000000000000000000001512576164335020046 0ustar0000000000000000broken cabal ghc-mod-5.4.0.0/test/data/broken-cabal/cabal.sandbox.config.in0000644000000000000000000000171412576164335022104 0ustar0000000000000000-- This is a Cabal package environment file. -- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY. -- Please create a 'cabal.config' file in the same directory -- if you want to change the default settings for this sandbox. local-repo: @CWD@/test/data/broken-cabal/.cabal-sandbox/packages logs-dir: @CWD@/test/data/broken-cabal/.cabal-sandbox/logs world-file: @CWD@/test/data/broken-cabal/.cabal-sandbox/world user-install: False package-db: @CWD@/test/data/broken-cabal/.cabal-sandbox/x86_64-linux-ghc-7.8.3-packages.conf.d build-summary: @CWD@/test/data/broken-cabal/.cabal-sandbox/logs/build.log install-dirs prefix: @CWD@/test/data/broken-cabal/.cabal-sandbox bindir: $prefix/bin libdir: $prefix/lib libsubdir: $arch-$os-$compiler/$pkgid libexecdir: $prefix/libexec datadir: $prefix/share datasubdir: $arch-$os-$compiler/$pkgid docdir: $datadir/doc/$arch-$os-$compiler/$pkgid htmldir: $docdir/html haddockdir: $htmldir sysconfdir: $prefix/etc ghc-mod-5.4.0.0/test/data/broken-sandbox/0000755000000000000000000000000012576164335016202 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/broken-sandbox/cabal.sandbox.config0000644000000000000000000000000712576164335022065 0ustar0000000000000000broken ghc-mod-5.4.0.0/test/data/broken-sandbox/dummy.cabal0000644000000000000000000000000612576164335020315 0ustar0000000000000000dummy ghc-mod-5.4.0.0/test/data/cabal-flags/0000755000000000000000000000000012576164335015422 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/cabal-flags/cabal-flags.cabal0000644000000000000000000000030112576164335020534 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.4.0.0/test/data/cabal-project/0000755000000000000000000000000012576164335015774 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/cabal-project/cabalapi.cabal0000644000000000000000000000471012576164335020516 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.4.0.0/test/data/cabal-project/Baz.hs0000644000000000000000000000014312576164335017042 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} module Baz (baz) where import Foo (fooQ) baz = [fooQ| foo bar baz |] ghc-mod-5.4.0.0/test/data/cabal-project/Foo.hs0000644000000000000000000000034312576164335017053 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.4.0.0/test/data/cabal-project/Info.hs0000644000000000000000000000022612576164335017223 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.4.0.0/test/data/cabal-project/Main.hs0000644000000000000000000000004612576164335017214 0ustar0000000000000000import Bar (bar) main = putStrLn bar ghc-mod-5.4.0.0/test/data/cabal-project/cabal.sandbox.config.in0000644000000000000000000000171612576164335022274 0ustar0000000000000000-- This is a Cabal package environment file. -- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY. -- Please create a 'cabal.config' file in the same directory -- if you want to change the default settings for this sandbox. local-repo: @CWD@/test/data/cabal-project/.cabal-sandbox/packages logs-dir: @CWD@/test/data/cabal-project/.cabal-sandbox/logs world-file: @CWD@/test/data/cabal-project/.cabal-sandbox/world user-install: False package-db: @CWD@/test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d build-summary: @CWD@/test/data/cabal-project/.cabal-sandbox/logs/build.log install-dirs prefix: @CWD@/test/data/cabal-project/.cabal-sandbox bindir: $prefix/bin libdir: $prefix/lib libsubdir: $arch-$os-$compiler/$pkgid libexecdir: $prefix/libexec datadir: $prefix/share datasubdir: $arch-$os-$compiler/$pkgid docdir: $datadir/doc/$arch-$os-$compiler/$pkgid htmldir: $docdir/html haddockdir: $htmldir sysconfdir: $prefix/etc ghc-mod-5.4.0.0/test/data/cabal-project/.cabal-sandbox/0000755000000000000000000000000012576164335020550 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/0000755000000000000000000000000012576164335026202 5ustar0000000000000000i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf0000644000000000000000000000014012576164335035141 0ustar0000000000000000ghc-mod-5.4.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.4.0.0/test/data/cabal-project/subdir1/0000755000000000000000000000000012576164335017345 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/cabal-project/subdir1/subdir2/0000755000000000000000000000000012576164335020717 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/cabal-project/subdir1/subdir2/dummy0000644000000000000000000000000612576164335021771 0ustar0000000000000000dummy ghc-mod-5.4.0.0/test/data/case-split/0000755000000000000000000000000012576164335015332 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/case-split/Vect.hs0000644000000000000000000000204312576164335016566 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.4.0.0/test/data/check-packageid/0000755000000000000000000000000012576164335016251 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/check-packageid/cabal.sandbox.config.in0000644000000000000000000000173212576164335022547 0ustar0000000000000000-- This is a Cabal package environment file. -- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY. -- Please create a 'cabal.config' file in the same directory -- if you want to change the default settings for this sandbox. local-repo: @CWD@/test/data/check-packageid/.cabal-sandbox/packages logs-dir: @CWD@/test/data/check-packageid/.cabal-sandbox/logs world-file: @CWD@/test/data/check-packageid/.cabal-sandbox/world user-install: False package-db: @CWD@/test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d build-summary: @CWD@/test/data/check-packageid/.cabal-sandbox/logs/build.log install-dirs prefix: @CWD@/test/data/check-packageid/.cabal-sandbox bindir: $prefix/bin libdir: $prefix/lib libsubdir: $arch-$os-$compiler/$pkgid libexecdir: $prefix/libexec datadir: $prefix/share datasubdir: $arch-$os-$compiler/$pkgid docdir: $datadir/doc/$arch-$os-$compiler/$pkgid htmldir: $docdir/html haddockdir: $htmldir sysconfdir: $prefix/etc ghc-mod-5.4.0.0/test/data/check-packageid/.cabal-sandbox/0000755000000000000000000000000012576164335021025 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/0000755000000000000000000000000012576164335026457 5ustar0000000000000000i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf0000644000000000000000000000016412576164335040001 0ustar0000000000000000ghc-mod-5.4.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.4.0.0/test/data/check-test-subdir/0000755000000000000000000000000012576164335016606 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/check-test-subdir/check-test-subdir.cabal0000644000000000000000000000047112576164335023114 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.4.0.0/test/data/check-test-subdir/src/0000755000000000000000000000000012576164335017375 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/check-test-subdir/src/Check/0000755000000000000000000000000012576164335020412 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/check-test-subdir/src/Check/Test/0000755000000000000000000000000012576164335021331 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/check-test-subdir/src/Check/Test/Subdir.hs0000644000000000000000000000011412576164335023111 0ustar0000000000000000module Check.Test.Subdir (subdir) where subdir :: String subdir = "subdir" ghc-mod-5.4.0.0/test/data/check-test-subdir/test/0000755000000000000000000000000012576164335017565 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/check-test-subdir/test/Foo.hs0000644000000000000000000000004412576164335020642 0ustar0000000000000000module Foo (foo) where foo = "foo" ghc-mod-5.4.0.0/test/data/check-test-subdir/test/Main.hs0000644000000000000000000000011212576164335020777 0ustar0000000000000000module Main where import Bar.Baz (baz) main :: IO () main = putStrLn baz ghc-mod-5.4.0.0/test/data/check-test-subdir/test/Bar/0000755000000000000000000000000012576164335020271 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/check-test-subdir/test/Bar/Baz.hs0000644000000000000000000000012612576164335021340 0ustar0000000000000000module Bar.Baz (baz) where import Foo (foo) baz :: String baz = unwords [foo, "baz"] ghc-mod-5.4.0.0/test/data/duplicate-pkgver/0000755000000000000000000000000012576164335016534 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/duplicate-pkgver/cabal.sandbox.config.in0000644000000000000000000000174012576164335023031 0ustar0000000000000000-- This is a Cabal package environment file. -- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY. -- Please create a 'cabal.config' file in the same directory -- if you want to change the default settings for this sandbox. local-repo: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox/packages logs-dir: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox/logs world-file: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox/world user-install: False package-db: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d build-summary: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox/logs/build.log install-dirs prefix: @CWD@/test/data/duplicate-pkgver/.cabal-sandbox bindir: $prefix/bin libdir: $prefix/lib libsubdir: $arch-$os-$compiler/$pkgid libexecdir: $prefix/libexec datadir: $prefix/share datasubdir: $arch-$os-$compiler/$pkgid docdir: $datadir/doc/$arch-$os-$compiler/$pkgid htmldir: $docdir/html haddockdir: $htmldir sysconfdir: $prefix/etc ghc-mod-5.4.0.0/test/data/duplicate-pkgver/duplicate-pkgver.cabal0000644000000000000000000000016512576164335022770 0ustar0000000000000000name: duplicate-pkgver version: 0.1.0 build-type: Simple cabal-version: >= 1.8 library build-depends: base == 4.* ghc-mod-5.4.0.0/test/data/duplicate-pkgver/.cabal-sandbox/0000755000000000000000000000000012576164335021310 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/0000755000000000000000000000000012576164335026742 5ustar0000000000000000i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-1.0-7c59d13f32294d1ef6dc6233c24df961.conf0000644000000000000000000000015412576164335037567 0ustar0000000000000000ghc-mod-5.4.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.conf0000644000000000000000000000016412576164335040223 0ustar0000000000000000ghc-mod-5.4.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.conf0000644000000000000000000000016412576164335040264 0ustar0000000000000000ghc-mod-5.4.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.4.0.0/test/data/foreign-export/0000755000000000000000000000000012576164335016236 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/foreign-export/ForeignExport.hs0000644000000000000000000000023112576164335021361 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface #-} module ForeignExport where import Foreign.C.Types foreign export ccall foo :: CUInt foo :: CUInt foo = 123 ghc-mod-5.4.0.0/test/data/ghc-mod-check/0000755000000000000000000000000012576164335015657 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/ghc-mod-check/ghc-mod-check.cabal0000644000000000000000000000130012576164335021226 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.4.0.0/test/data/ghc-mod-check/main.hs0000644000000000000000000000006512576164335017140 0ustar0000000000000000module Main where import Data.Foo main = print foo ghc-mod-5.4.0.0/test/data/ghc-mod-check/lib/0000755000000000000000000000000012576164335016425 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/ghc-mod-check/lib/Data/0000755000000000000000000000000012576164335017276 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/ghc-mod-check/lib/Data/Foo.hs0000644000000000000000000000027312576164335020357 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.4.0.0/test/data/hlint/0000755000000000000000000000000012576164335014404 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/hlint/hlint.hs0000644000000000000000000000011112576164335016047 0ustar0000000000000000module Hlist where main :: IO () main = do putStrLn "Hello, world!" ghc-mod-5.4.0.0/test/data/home-module-graph/0000755000000000000000000000000012576164335016600 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/home-module-graph/cpp/0000755000000000000000000000000012576164335017362 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/home-module-graph/cpp/A.hs0000644000000000000000000000005512576164335020076 0ustar0000000000000000module A where import A1 import A2 import A3 ghc-mod-5.4.0.0/test/data/home-module-graph/cpp/A1.hs0000644000000000000000000000006412576164335020157 0ustar0000000000000000{-# LANGUAGE CPP #-} module A1 where #elif import B ghc-mod-5.4.0.0/test/data/home-module-graph/cpp/A2.hs0000644000000000000000000000002012576164335020150 0ustar0000000000000000module A2 where ghc-mod-5.4.0.0/test/data/home-module-graph/cpp/A3.hs0000644000000000000000000000003112576164335020153 0ustar0000000000000000module A3 where import B ghc-mod-5.4.0.0/test/data/home-module-graph/cpp/B.hs0000644000000000000000000000001712576164335020075 0ustar0000000000000000module B where ghc-mod-5.4.0.0/test/data/home-module-graph/cycle/0000755000000000000000000000000012576164335017677 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/home-module-graph/cycle/A.hs0000644000000000000000000000003012576164335020404 0ustar0000000000000000module A where import B ghc-mod-5.4.0.0/test/data/home-module-graph/cycle/B.hs0000644000000000000000000000003012576164335020405 0ustar0000000000000000module B where import A ghc-mod-5.4.0.0/test/data/home-module-graph/errors/0000755000000000000000000000000012576164335020114 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/home-module-graph/errors/A.hs0000644000000000000000000000005512576164335020630 0ustar0000000000000000module A where import A1 import A2 import A3 ghc-mod-5.4.0.0/test/data/home-module-graph/errors/A1.hs0000644000000000000000000000006512576164335020712 0ustar0000000000000000module A1 where psogduapzsü9 import B lxäö,vLMCks ghc-mod-5.4.0.0/test/data/home-module-graph/errors/A2.hs0000644000000000000000000000002012576164335020702 0ustar0000000000000000module A2 where ghc-mod-5.4.0.0/test/data/home-module-graph/errors/A3.hs0000644000000000000000000000003112576164335020705 0ustar0000000000000000module A3 where import B ghc-mod-5.4.0.0/test/data/home-module-graph/errors/B.hs0000644000000000000000000000001712576164335020627 0ustar0000000000000000module B where ghc-mod-5.4.0.0/test/data/home-module-graph/indirect/0000755000000000000000000000000012576164335020401 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/home-module-graph/indirect/A.hs0000644000000000000000000000005512576164335021115 0ustar0000000000000000module A where import A1 import A2 import A3 ghc-mod-5.4.0.0/test/data/home-module-graph/indirect/A1.hs0000644000000000000000000000003112576164335021170 0ustar0000000000000000module A1 where import B ghc-mod-5.4.0.0/test/data/home-module-graph/indirect/A2.hs0000644000000000000000000000003112576164335021171 0ustar0000000000000000module A2 where import C ghc-mod-5.4.0.0/test/data/home-module-graph/indirect/A3.hs0000644000000000000000000000003112576164335021172 0ustar0000000000000000module A3 where import B ghc-mod-5.4.0.0/test/data/home-module-graph/indirect/B.hs0000644000000000000000000000001712576164335021114 0ustar0000000000000000module B where ghc-mod-5.4.0.0/test/data/home-module-graph/indirect/C.hs0000644000000000000000000000001712576164335021115 0ustar0000000000000000module C where ghc-mod-5.4.0.0/test/data/home-module-graph/indirect-update/0000755000000000000000000000000012576164335021661 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/home-module-graph/indirect-update/A.hs0000644000000000000000000000005512576164335022375 0ustar0000000000000000module A where import A1 import A2 import A3 ghc-mod-5.4.0.0/test/data/home-module-graph/indirect-update/A1.hs0000644000000000000000000000003112576164335022450 0ustar0000000000000000module A1 where import B ghc-mod-5.4.0.0/test/data/home-module-graph/indirect-update/A2.hs0000644000000000000000000000002012576164335022447 0ustar0000000000000000module A2 where ghc-mod-5.4.0.0/test/data/home-module-graph/indirect-update/A3.hs0000644000000000000000000000003112576164335022452 0ustar0000000000000000module A3 where import B ghc-mod-5.4.0.0/test/data/home-module-graph/indirect-update/B.hs0000644000000000000000000000001712576164335022374 0ustar0000000000000000module B where ghc-mod-5.4.0.0/test/data/home-module-graph/indirect-update/C.hs0000644000000000000000000000001712576164335022375 0ustar0000000000000000module C where ghc-mod-5.4.0.0/test/data/import-cycle/0000755000000000000000000000000012576164335015675 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/import-cycle/Mutual1.hs0000644000000000000000000000013512576164335017560 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} -- for HscInterpreted module Mutual1 where import Mutual2 ghc-mod-5.4.0.0/test/data/import-cycle/Mutual2.hs0000644000000000000000000000004512576164335017561 0ustar0000000000000000module Mutual2 where import Mutual1 ghc-mod-5.4.0.0/test/data/non-exported/0000755000000000000000000000000012576164335015710 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/non-exported/Fib.hs0000644000000000000000000000022512576164335016743 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.4.0.0/test/data/pattern-synonyms/0000755000000000000000000000000012576164335016640 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/pattern-synonyms/pattern-synonyms.cabal0000644000000000000000000000122412576164335023175 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: -Wallghc-mod-5.4.0.0/test/data/pattern-synonyms/A.hs0000644000000000000000000000017112576164335017353 0ustar0000000000000000{-# LANGUAGE PatternSynonyms #-} module A where data SomeType a b = SomeType (a,b) pattern MyPat x y <- SomeType (x,y) ghc-mod-5.4.0.0/test/data/pattern-synonyms/B.hs0000644000000000000000000000023312576164335017353 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.4.0.0/test/data/pattern-synonyms/Setup.hs0000644000000000000000000000005612576164335020275 0ustar0000000000000000import Distribution.Simple main = defaultMain ghc-mod-5.4.0.0/test/data/quasi-quotes/0000755000000000000000000000000012576164335015726 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/quasi-quotes/FooQ.hs0000644000000000000000000000027612576164335017133 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.4.0.0/test/data/quasi-quotes/QuasiQuotes.hs0000644000000000000000000000014012576164335020540 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} module QuasiQuotes where import FooQ bar = [fooQ| foo bar baz |] ghc-mod-5.4.0.0/test/data/template-haskell/0000755000000000000000000000000012576164335016522 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/template-haskell/Bar.hs0000644000000000000000000000013612576164335017562 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Bar (bar) where import Foo (foo) bar = $foo ++ "bar" ghc-mod-5.4.0.0/test/data/template-haskell/Foo.hs0000644000000000000000000000034312576164335017601 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.4.0.0/test/data/template-haskell/ImportsTH.hs0000644000000000000000000000004612576164335020747 0ustar0000000000000000import Bar (bar) main = putStrLn bar ghc-mod-5.4.0.0/test/data/target/0000755000000000000000000000000012576164335014554 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/target/Cpp.hs0000644000000000000000000000015312576164335015631 0ustar0000000000000000{-# LANGUAGE CPP #-} #undef NOTHING #ifdef NOTHING module WRONG_MODULE where #else module Cpp where #endif ghc-mod-5.4.0.0/test/data/check-missing-warnings/0000755000000000000000000000000012576164335017640 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/check-missing-warnings/DesugarWarnings.hs0000644000000000000000000000013212576164335023273 0ustar0000000000000000module Warnings (zoo) where zoo :: [a] -> () zoo x = case x of [] -> undefined ghc-mod-5.4.0.0/test/data/custom-cradle/0000755000000000000000000000000012576164335016030 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/custom-cradle/custom-cradle.cabal0000644000000000000000000000044712576164335021563 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.4.0.0/test/data/custom-cradle/ghc-mod.package-db-stack0000644000000000000000000000006312576164335022350 0ustar0000000000000000global user package-db-a package-db-b package-db-c ghc-mod-5.4.0.0/test/data/custom-cradle/package-db-a/0000755000000000000000000000000012576164335020224 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/custom-cradle/package-db-a/.gitkeep0000644000000000000000000000000012576164335021643 0ustar0000000000000000ghc-mod-5.4.0.0/test/data/custom-cradle/package-db-b/0000755000000000000000000000000012576164335020225 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/custom-cradle/package-db-b/.gitkeep0000644000000000000000000000000012576164335021644 0ustar0000000000000000ghc-mod-5.4.0.0/test/data/custom-cradle/package-db-c/0000755000000000000000000000000012576164335020226 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/custom-cradle/package-db-c/.gitkeep0000644000000000000000000000000012576164335021645 0ustar0000000000000000ghc-mod-5.4.0.0/test/data/cabal-preprocessors/0000755000000000000000000000000012576164335017237 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/cabal-preprocessors/cabal-preprocessors.cabal0000644000000000000000000000061312576164335024174 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.4.0.0/test/data/cabal-preprocessors/Main.hs0000644000000000000000000000007112576164335020455 0ustar0000000000000000import Preprocessed main :: IO () main = return warning ghc-mod-5.4.0.0/test/data/cabal-preprocessors/Preprocessed.hsc0000644000000000000000000000005012576164335022367 0ustar0000000000000000module Preprocessed where warning = () ghc-mod-5.4.0.0/test/data/file-mapping/0000755000000000000000000000000012576164335015636 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/file-mapping/File.hs0000644000000000000000000000005512576164335017051 0ustar0000000000000000main :: IO () main = putStrLn "Hello World!" ghc-mod-5.4.0.0/test/data/file-mapping/File_Redir.hs0000644000000000000000000000003712576164335020176 0ustar0000000000000000main = putStrLn "Hello World!" ghc-mod-5.4.0.0/test/data/file-mapping/File_Redir_Lint.hs0000644000000000000000000000010312576164335021156 0ustar0000000000000000module File where func :: Num a => a -> a -> a func a b = (*) a b ghc-mod-5.4.0.0/test/data/file-mapping/preprocessor/0000755000000000000000000000000012576164335020364 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/file-mapping/preprocessor/File.hs0000644000000000000000000000014712576164335021601 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef NOTHING main :: IO () main = putStrLn "Hello World!" #else INVALID #endif ghc-mod-5.4.0.0/test/data/file-mapping/preprocessor/File_Redir.hs0000644000000000000000000000013112576164335022717 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifndef NOTHING main = putStrLn "Hello World!" #else INVALID #endif ghc-mod-5.4.0.0/test/data/file-mapping/preprocessor/File_Redir_Lint.hs0000644000000000000000000000017512576164335023715 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.4.0.0/test/data/file-mapping/lhs/0000755000000000000000000000000012576164335016424 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/file-mapping/lhs/File.lhs0000644000000000000000000000006112576164335020010 0ustar0000000000000000> main :: IO () > main = putStrLn "Hello World!" ghc-mod-5.4.0.0/test/data/file-mapping/lhs/File_Redir.lhs0000644000000000000000000000004112576164335021133 0ustar0000000000000000> main = putStrLn "Hello World!" ghc-mod-5.4.0.0/test/data/file-mapping/lhs/File_Redir_Lint.lhs0000644000000000000000000000011112576164335022117 0ustar0000000000000000> module File where > func :: Num a => a -> a -> a > func a b = (*) a b ghc-mod-5.4.0.0/test/data/nice-qualification/0000755000000000000000000000000012576164335017032 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/nice-qualification/NiceQualification.hs0000644000000000000000000000006512576164335022756 0ustar0000000000000000module Main where main :: IO () main = "wrong type" ghc-mod-5.4.0.0/test/data/stack-project/0000755000000000000000000000000012576164335016037 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/stack-project/stack.yaml0000644000000000000000000000007412576164335020031 0ustar0000000000000000flags: {} packages: - '.' extra-deps: [] resolver: lts-2.17 ghc-mod-5.4.0.0/test/data/stack-project/new-template.cabal0000644000000000000000000000236312576164335021431 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 >= 4.7 && < 5 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.4.0.0/test/data/stack-project/Setup.hs0000644000000000000000000000005612576164335017474 0ustar0000000000000000import Distribution.Simple main = defaultMain ghc-mod-5.4.0.0/test/data/stack-project/app/0000755000000000000000000000000012576164335016617 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/stack-project/app/Main.hs0000644000000000000000000000007512576164335020041 0ustar0000000000000000module Main where import Lib main :: IO () main = someFunc ghc-mod-5.4.0.0/test/data/stack-project/src/0000755000000000000000000000000012576164335016626 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/stack-project/src/Lib.hs0000644000000000000000000000013012576164335017662 0ustar0000000000000000module Lib ( someFunc ) where someFunc :: IO () someFunc = putStrLn "someFunc" ghc-mod-5.4.0.0/test/data/stack-project/test/0000755000000000000000000000000012576164335017016 5ustar0000000000000000ghc-mod-5.4.0.0/test/data/stack-project/test/Spec.hs0000644000000000000000000000007712576164335020250 0ustar0000000000000000main :: IO () main = putStrLn "Test suite not yet implemented" ghc-mod-5.4.0.0/elisp/0000755000000000000000000000000012576164335012512 5ustar0000000000000000ghc-mod-5.4.0.0/elisp/Makefile0000644000000000000000000000252612576164335014157 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.4.0.0/elisp/ghc-pkg.el0000644000000000000000000000013212576164335014350 0ustar0000000000000000(define-package "ghc" 2.0.0 "Sub mode for Haskell mode" '((haskell-mode "13.0"))) ghc-mod-5.4.0.0/elisp/ghc-check.el0000644000000000000000000004141112576164335014651 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.4.0.0/elisp/ghc-command.el0000644000000000000000000000515212576164335015214 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.4.0.0/elisp/ghc-comp.el0000644000000000000000000001717612576164335014545 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 nil 'skip-map-file) (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.4.0.0/elisp/ghc-doc.el0000644000000000000000000000756412576164335014354 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.4.0.0/elisp/ghc-func.el0000644000000000000000000001774212576164335014541 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 (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.4.0.0/elisp/ghc-indent.el0000644000000000000000000000075712576164335015065 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.4.0.0/elisp/ghc-info.el0000644000000000000000000001047612576164335014536 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 'ghc-type-fix-string))) (defun ghc-type-fix-string () (save-excursion (goto-char (point-min)) (while (search-forward "[Char]" nil t) (replace-match "String")))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; 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.4.0.0/elisp/ghc-ins-mod.el0000644000000000000000000000420112576164335015136 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.4.0.0/elisp/ghc-process.el0000644000000000000000000001555512576164335015264 0ustar0000000000000000;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; 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-callback nil) (defvar-local ghc-process-hook nil) (defvar-local ghc-process-root nil) (defvar ghc-command "ghc-mod") (defvar ghc-error-buffer "*GHC Error*") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun ghc-get-project-root () (ghc-run-ghc-mod '("root"))) (defun ghc-with-process (cmd callback &optional hook1 hook2 skip-map-file) (unless ghc-process-process-name (setq ghc-process-process-name (ghc-get-project-root))) (when (and ghc-process-process-name (not ghc-process-running)) (setq ghc-process-running t) (if hook1 (funcall hook1)) (let* ((cbuf (current-buffer)) (name ghc-process-process-name) (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-hook hook2) (setq ghc-process-root root) (let ((pro (ghc-get-process cpro name buf root)) (map-cmd (format "map-file %s\n" file))) ;; map-file (unless skip-map-file (setq ghc-process-file-mapping t) (setq ghc-process-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 "\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-callback callback) (erase-buffer) (when ghc-debug (ghc-with-debug-buffer (insert (format "%% %s" cmd)))) (process-send-string pro 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)) (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-callback (if ghc-process-hook (funcall ghc-process-hook)) (goto-char (point-min)) (funcall ghc-process-callback 'ok) (setq ghc-process-running nil))) ((looking-at "^NG ") (funcall ghc-process-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 hook skip-map-file) (unless ghc-process-running (setq ghc-process-rendezvous nil) (setq ghc-process-results nil) (setq ghc-process-num-of-results (or n 1)) (let ((pro (ghc-with-process cmd 'ghc-process-callback nil hook skip-map-file))) ;; 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-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.4.0.0/elisp/ghc-rewrite.el0000644000000000000000000001551212576164335015260 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.4.0.0/elisp/ghc.el0000644000000000000000000001334312576164335013601 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.4.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) ghc-mod-5.4.0.0/NotCPP/0000755000000000000000000000000012576164335012501 5ustar0000000000000000ghc-mod-5.4.0.0/NotCPP/Declarations.hs0000644000000000000000000001244612576164335015454 0ustar0000000000000000-- ghc-mod: Making Haskell development *more* fun -- Copyright (C) 2015 Daniel Gröber -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of the GNU Affero General Public License as published by -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU Affero General Public License for more details. -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . {-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# LANGUAGE CPP #-} -- Using CPP so you don't have to :) module NotCPP.Declarations where import Control.Arrow import Control.Applicative import Data.Maybe import Language.Haskell.TH.Syntax import NotCPP.LookupValueName nT :: Monad m => String -> m Type cT :: Monad m => String -> m Type nE :: Monad m => String -> m Exp nP :: Monad m => String -> m Pat nT str = return $ VarT (mkName str) cT str = return $ ConT (mkName str) nE str = return $ VarE (mkName str) nP str = return $ VarP (mkName str) recUpdE' :: Q Exp -> Name -> Exp -> Q Exp recUpdE' ex name assign = do RecUpdE <$> ex <*> pure [(name, assign)] lookupName' :: (NameSpace, String) -> Q (Maybe Name) lookupName' (VarName, n) = lookupValueName n lookupName' (DataName, n) = lookupValueName n lookupName' (TcClsName, n) = lookupTypeName n -- Does this even make sense? ifelseD :: Q [Dec] -> Q [Dec] -> Q [Dec] ifelseD if_decls' else_decls = do if_decls <- if_decls' alreadyDefined <- definedNames (boundNames `concatMap` if_decls) case alreadyDefined of [] -> if_decls' _ -> else_decls ifdefelseD, ifelsedefD :: String -> Q [Dec] -> Q [Dec] -> Q [Dec] ifelsedefD = ifdefelseD ifdefelseD ident if_decls else_decls = do exists <- isJust <$> lookupValueName ident if exists then if_decls else else_decls ifdefD :: String -> Q [Dec] -> Q [Dec] ifdefD ident decls = ifdefelseD ident decls (return []) ifndefD :: String -> Q [Dec] -> Q [Dec] ifndefD ident decls = ifdefelseD ident (return []) decls -- | Each of the given declarations is only spliced if the identifier it defines -- is not defined yet. -- -- For example: -- -- @$(ifD [[d| someFunctionThatShouldExist x = x+1 |]]@ -- -- If @someFunctionThatShouldExist@ doesn't actually exist the definition given -- in the splice will be the result of the splice otherwise nothing will be -- spliced. -- -- Currently this only works for function declarations but it can be easily -- extended to other kinds of declarations. ifD :: Q [Dec] -> Q [Dec] ifD decls' = do decls <- decls' concat <$> flip mapM decls (\decl -> do alreadyDefined <- definedNames (boundNames decl) case alreadyDefined of [] -> return [decl] _ -> return []) definedNames :: [(NameSpace, Name)] -> Q [Name] definedNames ns = catMaybes <$> (lookupName' . second nameBase) `mapM` ns boundNames :: Dec -> [(NameSpace, Name)] boundNames decl = case decl of SigD n _ -> [(VarName, n)] FunD n _cls -> [(VarName, n)] #if __GLASGOW_HASKELL__ >= 706 InfixD _ n -> [(VarName, n)] #endif ValD p _ _ -> map ((,) VarName) $ patNames p TySynD n _ _ -> [(TcClsName, n)] ClassD _ n _ _ _ -> [(TcClsName, n)] FamilyD _ n _ _ -> [(TcClsName, n)] DataD _ n _ ctors _ -> [(TcClsName, n)] ++ map ((,) TcClsName) (conNames `concatMap` ctors) NewtypeD _ n _ ctor _ -> [(TcClsName, n)] ++ map ((,) TcClsName) (conNames ctor) DataInstD _ _n _ ctors _ -> map ((,) TcClsName) (conNames `concatMap` ctors) NewtypeInstD _ _n _ ctor _ -> map ((,) TcClsName) (conNames ctor) InstanceD _ _ty _ -> error "notcpp: Instance declarations are not supported yet" ForeignD _ -> error "notcpp: Foreign declarations are not supported yet" PragmaD _pragma -> error "notcpp: pragmas are not supported yet" #if __GLASGOW_HASKELL__ >= 708 TySynInstD _n _ -> error "notcpp: TySynInstD not supported yet" #else TySynInstD _n _ _ -> error "notcpp: TySynInstD not supported yet" #endif #if __GLASGOW_HASKELL__ >= 708 ClosedTypeFamilyD n _ _ _ -> [(TcClsName, n)] RoleAnnotD _n _ -> error "notcpp: RoleAnnotD not supported yet" #endif conNames :: Con -> [Name] conNames con = case con of NormalC n _ -> [n] RecC n _ -> [n] InfixC _ n _ -> [n] ForallC _ _ c -> conNames c patNames :: Pat -> [Name] patNames p'' = case p'' of LitP _ -> [] VarP n -> [n] TupP ps -> patNames `concatMap` ps UnboxedTupP ps -> patNames `concatMap` ps ConP _ ps -> patNames `concatMap` ps InfixP p _ p' -> patNames `concatMap` [p,p'] UInfixP p _ p' -> patNames `concatMap` [p,p'] ParensP p -> patNames p TildeP p -> patNames p BangP p -> patNames p AsP n p -> n:(patNames p) WildP -> [] RecP _ fps -> patNames `concatMap` map snd fps ListP ps -> patNames `concatMap` ps SigP p _ -> patNames p ViewP _ p -> patNames p ghc-mod-5.4.0.0/NotCPP/LookupValueName.hs0000644000000000000000000000233112576164335016103 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} -- | This module uses scope lookup techniques to either export -- 'lookupValueName' from @Language.Haskell.TH@, or define -- its own 'lookupValueName', which attempts to do the -- same job with just 'reify'. This will sometimes fail, but if it -- succeeds it will give the answer that the real function would have -- given. -- -- The idea is that if you use lookupValueName from this module, -- your client code will automatically use the best available name -- lookup mechanism. This means that e.g. 'scopeLookup' can work -- very well on recent GHCs and less well but still somewhat -- usefully on older GHCs. module NotCPP.LookupValueName ( lookupValueName ) where import Language.Haskell.TH import NotCPP.Utils bestValueGuess :: String -> Q (Maybe Name) bestValueGuess s = do mi <- maybeReify (mkName s) case mi of Nothing -> no Just i -> case i of VarI n _ _ _ -> yes n DataConI n _ _ _ -> yes n _ -> err ["unexpected info:", show i] where no = return Nothing yes = return . Just err = fail . showString "NotCPP.bestValueGuess: " . unwords $(recover [d| lookupValueName = bestValueGuess |] $ do VarI _ _ _ _ <- reify (mkName "lookupValueName") return []) ghc-mod-5.4.0.0/NotCPP/OrphanEvasion.hs0000644000000000000000000000753212576164335015620 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls, TemplateHaskell #-} -- | -- The orphan instance problem is well-known in Haskell. This module -- by no means purports to solve the problem, but provides a workaround -- that may be significantly less awful than the status quo in some -- cases. -- -- Say I think that the 'Name' type should have an 'IsString' instance. -- But I don't control either the class or the type, so if I define the -- instance, and then the template-haskell package defines one, my code -- is going to break. -- -- 'safeInstance' can help me to solve this problem: -- -- > safeInstance ''IsString [t| Name |] [d| -- > fromString = mkName |] -- -- This will declare an instance only if one doesn't already exist. -- Now anyone importing your module is guaranteed to get an instance -- one way or the other. -- -- This module is still highly experimental. The example given above -- does work, but anything involving type variables or complex method -- bodies may be less fortunate. The names of the methods are mangled -- a bit, so using recursion to define them may not work. Define the -- method outside the code and then use a simple binding as above. -- -- If you use this code (successfully or unsuccessfully!), go fetch -- the maintainer address from the cabal file and let me know! module NotCPP.OrphanEvasion ( MultiParams, safeInstance, safeInstance', ) where import Control.Applicative import Language.Haskell.TH import Language.Haskell.TH.Syntax import NotCPP.ScopeLookup -- | An empty type used only to signify a multiparameter typeclass in -- 'safeInstance'. data MultiParams a -- | Given @(forall ts. Cxt => t)@, return @(Cxt, [t])@. -- Given @(forall ts. Cxt => 'MultiParams' (t1, t2, t3))@, return -- @(Cxt, [t1, t2, t3])@. -- -- This is used in 'safeInstance' to allow types to be specified more -- easily with TH typequotes. fromTuple :: Type -> (Cxt, [Type]) fromTuple ty = unTuple <$> case ty of ForallT _ cxt ty' -> (cxt, ty') _ -> ([], ty) where unTuple :: Type -> [Type] unTuple (AppT (ConT n) ta) | n == ''MultiParams = case unrollAppT ta of (TupleT{}, ts) -> ts _ -> [ty] unTuple t = [t] -- | A helper function to unwind type application. -- Given @TyCon t1 t2 t3@, returns @(TyCon, [t1,t2,t3])@ unrollAppT :: Type -> (Type, [Type]) unrollAppT = go [] where go acc (AppT tc ta) = go (ta : acc) tc go acc ty = (ty, reverse acc) -- | Left inverse to unrollAppT, equal to @'foldl' 'AppT'@ rollAppT :: Type -> [Type] -> Type rollAppT = foldl AppT -- | @'safeInstance'' className cxt types methods@ produces an instance -- of the given class if and only if one doesn't already exist. -- -- See 'safeInstance' for a simple way to construct the 'Cxt' and -- @['Type']@ parameters. safeInstance' :: Name -> Cxt -> [Type] -> Q [Dec] -> Q [Dec] safeInstance' cl cxt tys inst = do b <- $(scopeLookups ["isInstance", "isClassInstance"]) cl tys if b then return [] else do ds <- map fixInst <$> inst return [InstanceD cxt (rollAppT (ConT cl) tys) ds] where fixInst (FunD n cls) = FunD (fixName n) cls fixInst (ValD (VarP n) rhs wh) = ValD (VarP (fixName n)) rhs wh fixInst d = d fixName (Name n _) = Name n NameS -- | 'safeInstance' is a more convenient version of 'safeInstance'' -- that takes the context and type from a @'Q' 'Type'@ with the intention -- that it be supplied using a type-quote. -- -- To define an instance @Show a => Show (Wrapper a)@, you'd use: -- -- > safeInstance ''Show [t| Show a => Wrapper a |] -- > [d| show _ = "stuff" |] -- -- To define an instance of a multi-param type class, use the -- 'MultiParams' type constructor with a tuple: -- -- > safeInstance ''MonadState -- > [t| MonadState s m => MultiParams (s, MaybeT m) |] -- > [d| put = ... |] safeInstance :: Name -> Q Type -> Q [Dec] -> Q [Dec] safeInstance n qty inst = do (cxt, tys) <- fromTuple <$> qty safeInstance' n cxt tys inst ghc-mod-5.4.0.0/NotCPP/ScopeLookup.hs0000644000000000000000000000402712576164335015303 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} -- | -- This module exports 'scopeLookup', which will find a variable or -- value constructor for you and present it for your use. E.g. at some -- point in the history of the acid-state package, 'openAcidState' was -- renamed 'openLocalState'; for compatibility with both, you could -- use: -- -- > openState :: IO (AcidState st) -- > openState = case $(scopeLookup "openLocalState") of -- > Just open -> open defaultState -- > Nothing -> case $(scopeLookup "openAcidState") of -- > Just open -> open defaultState -- > Nothing -> error -- > "openState: runtime name resolution has its drawbacks :/" -- -- Or, for this specific case, you can use 'scopeLookups': -- -- > openState :: IO (AcidState st) -- > openState = open defaultState -- > where -- > open = $(scopeLookups ["openLocalState","openAcidState"]) -- -- Now if neither of the names are found then TH will throw a -- compile-time error. module NotCPP.ScopeLookup ( scopeLookup, scopeLookups, scopeLookup', liftMaybe, recoverMaybe, maybeReify, infoToExp, ) where import Control.Applicative ((<$>)) import Language.Haskell.TH (Q, Exp, recover, reify) import NotCPP.LookupValueName import NotCPP.Utils -- | Produces a spliceable expression which expands to @'Just' val@ if -- the given string refers to a value @val@ in scope, or 'Nothing' -- otherwise. -- -- @scopeLookup = 'fmap' 'liftMaybe' . 'scopeLookup''@ scopeLookup :: String -> Q Exp scopeLookup = fmap liftMaybe . scopeLookup' -- | Finds the first string in the list that names a value, and produces -- a spliceable expression of that value, or reports a compile error if -- it fails. scopeLookups :: [String] -> Q Exp scopeLookups xs = foldr (\s r -> maybe r return =<< scopeLookup' s) (fail ("scopeLookups: none found: " ++ show xs)) xs -- | Produces @'Just' x@ if the given string names the value @x@, -- or 'Nothing' otherwise. scopeLookup' :: String -> Q (Maybe Exp) scopeLookup' s = recover (return Nothing) $ do Just n <- lookupValueName s infoToExp <$> reify n ghc-mod-5.4.0.0/NotCPP/Utils.hs0000644000000000000000000000202612576164335014135 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module NotCPP.Utils where import Control.Applicative ((<$>)) import Language.Haskell.TH -- | Turns 'Nothing' into an expression representing 'Nothing', and -- @'Just' x@ into an expression representing 'Just' applied to the -- expression in @x@. liftMaybe :: Maybe Exp -> Exp liftMaybe = maybe (ConE 'Nothing) (AppE (ConE 'Just)) -- | A useful variant of 'reify' that returns 'Nothing' instead of -- halting compilation when an error occurs (e.g. because the given -- name was not in scope). maybeReify :: Name -> Q (Maybe Info) maybeReify = recoverMaybe . reify -- | Turns a possibly-failing 'Q' action into one returning a 'Maybe' -- value. recoverMaybe :: Q a -> Q (Maybe a) recoverMaybe q = recover (return Nothing) (Just <$> q) -- | Returns @'Just' ('VarE' n)@ if the info relates to a value called -- @n@, or 'Nothing' if it relates to a different sort of thing. infoToExp :: Info -> Maybe Exp infoToExp (VarI n _ _ _) = Just (VarE n) infoToExp (DataConI n _ _ _) = Just (ConE n) infoToExp _ = Nothing ghc-mod-5.4.0.0/NotCPP/COPYING0000644000000000000000000000275512576164335013545 0ustar0000000000000000Copyright Ben Millwood 2012 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 Ben Millwood nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.