ghc-mod 5.2.1.2 → 5.3.0.0

raw patch · 153 files changed

+6370/−3286 lines, 153 filesdep +bytestringdep +cabal-helperdep +cerealdep −Cabaldep −data-defaultdep −io-choicedep ~asyncdep ~containersdep ~deepseqbuild-type:Customsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, cabal-helper, cereal, fclabels, ghc-prim

Dependencies removed: Cabal, data-default, io-choice

Dependency ranges changed: async, containers, deepseq, directory, filepath, ghc, ghc-syb-utils, haskell-src-exts, hlint, hspec, monad-control, monad-journal, mtl, old-time, pretty, process, syb, text, time, transformers, transformers-base

API changes (from Hackage documentation)

Files

• COPYING.AGPL3 +661/−0
• COPYING.BSD3 +29/−0
• ChangeLog +9/−0
• LICENSE +5/−28
• Language/Haskell/GhcMod.hs +21/−2
• Language/Haskell/GhcMod/Boot.hs +4/−2
• Language/Haskell/GhcMod/Browse.hs +47/−41
• Language/Haskell/GhcMod/Cabal16.hs +0/−45
• Language/Haskell/GhcMod/Cabal18.hs +0/−58
• Language/Haskell/GhcMod/Cabal21.hs +0/−73
• Language/Haskell/GhcMod/CabalApi.hs +0/−193
• Language/Haskell/GhcMod/CabalConfig.hs +0/−171
• Language/Haskell/GhcMod/CabalHelper.hs +228/−0
• Language/Haskell/GhcMod/Caching.hs +103/−0
• Language/Haskell/GhcMod/Caching/Types.hs +52/−0
• Language/Haskell/GhcMod/CaseSplit.hs +48/−30
• Language/Haskell/GhcMod/Check.hs +16/−17
• Language/Haskell/GhcMod/Convert.hs +27/−22
• Language/Haskell/GhcMod/Cradle.hs +47/−33
• Language/Haskell/GhcMod/Debug.hs +113/−25
• Language/Haskell/GhcMod/Doc.hs +8/−4
• Language/Haskell/GhcMod/DynFlags.hs +8/−27
• Language/Haskell/GhcMod/Error.hs +161/−37
• Language/Haskell/GhcMod/FillSig.hs +132/−67
• Language/Haskell/GhcMod/Find.hs +65/−82
• Language/Haskell/GhcMod/GHCApi.hs +0/−86
• Language/Haskell/GhcMod/GHCChoice.hs +0/−23
• Language/Haskell/GhcMod/Gap.hs +116/−54
• Language/Haskell/GhcMod/GhcPkg.hs +24/−37
• Language/Haskell/GhcMod/HomeModuleGraph.hs +263/−0
• Language/Haskell/GhcMod/Info.hs +46/−28
• Language/Haskell/GhcMod/Internal.hs +24/−21
• Language/Haskell/GhcMod/Logger.hs +73/−155
• Language/Haskell/GhcMod/Logging.hs +102/−0
• Language/Haskell/GhcMod/Modules.hs +17/−23
• Language/Haskell/GhcMod/Monad.hs +78/−436
• Language/Haskell/GhcMod/Monad/Types.hs +442/−0
• Language/Haskell/GhcMod/Output.hs +199/−0
• Language/Haskell/GhcMod/PathsAndFiles.hs +156/−47
• Language/Haskell/GhcMod/PkgDoc.hs +9/−8
• Language/Haskell/GhcMod/Pretty.hs +69/−0
• Language/Haskell/GhcMod/SrcUtils.hs +4/−22
• Language/Haskell/GhcMod/Target.hs +464/−38
• Language/Haskell/GhcMod/Types.hs +293/−40
• Language/Haskell/GhcMod/Utils.hs +131/−66
• Language/Haskell/GhcMod/World.hs +25/−62
• NotCPP/Declarations.hs +164/−0
• NotCPP/LookupValueName.hs +38/−0
• NotCPP/OrphanEvasion.hs +114/−0
• NotCPP/ScopeLookup.hs +65/−0
• NotCPP/Utils.hs +29/−0
• Setup.hs +197/−1
• SetupCompat.hs +198/−0
• Utils.hs +37/−0
• elisp/ghc-check.el +35/−26
• elisp/ghc-comp.el +1/−1
• elisp/ghc-doc.el +2/−2
• elisp/ghc-func.el +12/−2
• elisp/ghc-info.el +2/−2
• elisp/ghc-pkg.el +1/−1
• elisp/ghc-process.el +82/−37
• elisp/ghc.el +5/−6
• ghc-mod.cabal +109/−103
• src/GHCMod.hs +242/−231
• src/GHCModi.hs +41/−248
• src/Misc.hs +7/−114
• src/Utils.hs +0/−27
• test/BrowseSpec.hs +5/−4
• test/CabalApiSpec.hs +0/−77
• test/CheckSpec.hs +32/−14
• test/Dir.hs +8/−2
• test/HomeModuleGraphSpec.hs +178/−0
• test/InfoSpec.hs +19/−27
• test/LintSpec.hs +3/−3
• test/Main.hs +21/−4
• test/MonadSpec.hs +1/−23
• test/PathsAndFilesSpec.hs +13/−22
• test/TestUtils.hs +68/−22
• test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf +0/−4
• test/data/.cabal-sandbox/packages/00-index.tar binary
• test/data/Bar.hs +0/−5
• test/data/Baz.hs +0/−5
• test/data/Foo.hs +0/−9
• test/data/ForeignExport.hs +0/−10
• test/data/Info.hs +0/−8
• test/data/Main.hs +0/−3
• test/data/Mutual1.hs +0/−5
• test/data/Mutual2.hs +0/−3
• test/data/Unicode.hs +0/−4
• test/data/annotations/With.hs +6/−0
• test/data/cabal-flags/cabal-flags.cabal +1/−2
• test/data/cabal-preprocessors/Main.hs +4/−0
• test/data/cabal-preprocessors/Preprocessed.hsc +3/−0
• test/data/cabal-preprocessors/cabal-preprocessors.cabal +14/−0
• test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf +4/−0
• test/data/cabal-project/Baz.hs +5/−0
• test/data/cabal-project/Foo.hs +9/−0
• test/data/cabal-project/Info.hs +8/−0
• test/data/cabal-project/Main.hs +3/−0
• test/data/cabal-project/cabal.sandbox.config.in +25/−0
• test/data/cabal-project/cabalapi.cabal +67/−0
• test/data/cabal-project/subdir1/subdir2/dummy +1/−0
• test/data/cabal.sandbox.config.in +0/−25
• test/data/cabalapi.cabal +0/−67
• test/data/check-missing-warnings/DesugarWarnings.hs +5/−0
• test/data/check-test-subdir/check-test-subdir.cabal +1/−0
• test/data/custom-cradle/custom-cradle.cabal +12/−0
• test/data/custom-cradle/ghc-mod.package-db-stack +5/−0
• test/data/custom-cradle/package-db-a/.gitkeep +0/−0
• test/data/custom-cradle/package-db-b/.gitkeep +0/−0
• test/data/custom-cradle/package-db-c/.gitkeep +0/−0
• test/data/foreign-export/ForeignExport.hs +10/−0
• test/data/ghc-mod-check/Data/Foo.hs +0/−11
• test/data/ghc-mod-check/ghc-mod-check.cabal +2/−3
• test/data/ghc-mod-check/lib/Data/Foo.hs +11/−0
• test/data/hlint.hs +0/−5
• test/data/hlint/hlint.hs +5/−0
• test/data/home-module-graph/cpp/A.hs +4/−0
• test/data/home-module-graph/cpp/A1.hs +4/−0
• test/data/home-module-graph/cpp/A2.hs +1/−0
• test/data/home-module-graph/cpp/A3.hs +2/−0
• test/data/home-module-graph/cpp/B.hs +1/−0
• test/data/home-module-graph/cycle/A.hs +2/−0
• test/data/home-module-graph/cycle/B.hs +2/−0
• test/data/home-module-graph/errors/A.hs +4/−0
• test/data/home-module-graph/errors/A1.hs +4/−0
• test/data/home-module-graph/errors/A2.hs +1/−0
• test/data/home-module-graph/errors/A3.hs +2/−0
• test/data/home-module-graph/errors/B.hs +1/−0
• test/data/home-module-graph/indirect-update/A.hs +4/−0
• test/data/home-module-graph/indirect-update/A1.hs +2/−0
• test/data/home-module-graph/indirect-update/A2.hs +1/−0
• test/data/home-module-graph/indirect-update/A3.hs +2/−0
• test/data/home-module-graph/indirect-update/B.hs +1/−0
• test/data/home-module-graph/indirect-update/C.hs +1/−0
• test/data/home-module-graph/indirect/A.hs +4/−0
• test/data/home-module-graph/indirect/A1.hs +2/−0
• test/data/home-module-graph/indirect/A2.hs +2/−0
• test/data/home-module-graph/indirect/A3.hs +2/−0
• test/data/home-module-graph/indirect/B.hs +1/−0
• test/data/home-module-graph/indirect/C.hs +1/−0
• test/data/import-cycle/Mutual1.hs +5/−0
• test/data/import-cycle/Mutual2.hs +3/−0
• test/data/non-exported/Fib.hs +8/−0
• test/data/pattern-synonyms/pattern-synonyms.cabal +11/−10
• test/data/quasi-quotes/FooQ.hs +6/−0
• test/data/quasi-quotes/QuasiQuotes.hs +6/−0
• test/data/subdir1/subdir2/dummy +0/−1
• test/data/target/Cpp.hs +7/−0
• test/data/template-haskell/Bar.hs +5/−0
• test/data/template-haskell/Foo.hs +9/−0
• test/data/template-haskell/ImportsTH.hs +3/−0
• test/doctests.hs +7/−4

@@ -0,0 +1,661 @@+                    GNU AFFERO GENERAL PUBLIC LICENSE+                       Version 3, 19 November 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++                            Preamble++  The GNU Affero General Public License is a free, copyleft license for+software and other kinds of works, specifically designed to ensure+cooperation with the community in the case of network server software.++  The licenses for most software and other practical works are designed+to take away your freedom to share and change the works.  By contrast,+our General Public Licenses are intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users.++  When we speak of free software, we are referring to freedom, not+price.  Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), that you receive source code or can get it if you+want it, that you can change the software or use pieces of it in new+free programs, and that you know you can do these things.++  Developers that use our General Public Licenses protect your rights+with two steps: (1) assert copyright on the software, and (2) offer+you this License which gives you legal permission to copy, distribute+and/or modify the software.++  A secondary benefit of defending all users' freedom is that+improvements made in alternate versions of the program, if they+receive widespread use, become available for other developers to+incorporate.  Many developers of free software are heartened and+encouraged by the resulting cooperation.  However, in the case of+software used on network servers, this result may fail to come about.+The GNU General Public License permits making a modified version and+letting the public access it on a server without ever releasing its+source code to the public.++  The GNU Affero General Public License is designed specifically to+ensure that, in such cases, the modified source code becomes available+to the community.  It requires the operator of a network server to+provide the source code of the modified version running there to the+users of that server.  Therefore, public use of a modified version, on+a publicly accessible server, gives the public access to the source+code of the modified version.++  An older license, called the Affero General Public License and+published by Affero, was designed to accomplish similar goals.  This is+a different license, not a version of the Affero GPL, but Affero has+released a new version of the Affero GPL which permits relicensing under+this license.++  The precise terms and conditions for copying, distribution and+modification follow.++                       TERMS AND CONDITIONS++  0. Definitions.++  "This License" refers to version 3 of the GNU Affero General Public License.++  "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++  "The Program" refers to any copyrightable work licensed under this+License.  Each licensee is addressed as "you".  "Licensees" and+"recipients" may be individuals or organizations.++  To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy.  The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++  A "covered work" means either the unmodified Program or a work based+on the Program.++  To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy.  Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++  To "convey" a work means any kind of propagation that enables other+parties to make or receive copies.  Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++  An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License.  If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++  1. Source Code.++  The "source code" for a work means the preferred form of the work+for making modifications to it.  "Object code" means any non-source+form of a work.++  A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++  The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form.  A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++  The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities.  However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work.  For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++  The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++  The Corresponding Source for a work in source code form is that+same work.++  2. Basic Permissions.++  All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met.  This License explicitly affirms your unlimited+permission to run the unmodified Program.  The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work.  This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++  You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force.  You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright.  Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++  Conveying under any other circumstances is permitted solely under+the conditions stated below.  Sublicensing is not allowed; section 10+makes it unnecessary.++  3. Protecting Users' Legal Rights From Anti-Circumvention Law.++  No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++  When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++  4. Conveying Verbatim Copies.++  You may convey verbatim copies of the Program's source code as you+receive it, in any medium, provided that you conspicuously and+appropriately publish on each copy an appropriate copyright notice;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++  You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++  5. Conveying Modified Source Versions.++  You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++    a) The work must carry prominent notices stating that you modified+    it, and giving a relevant date.++    b) The work must carry prominent notices stating that it is+    released under this License and any conditions added under section+    7.  This requirement modifies the requirement in section 4 to+    "keep intact all notices".++    c) You must license the entire work, as a whole, under this+    License to anyone who comes into possession of a copy.  This+    License will therefore apply, along with any applicable section 7+    additional terms, to the whole of the work, and all its parts,+    regardless of how they are packaged.  This License gives no+    permission to license the work in any other way, but it does not+    invalidate such permission if you have separately received it.++    d) If the work has interactive user interfaces, each must display+    Appropriate Legal Notices; however, if the Program has interactive+    interfaces that do not display Appropriate Legal Notices, your+    work need not make them do so.++  A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit.  Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++  6. Conveying Non-Source Forms.++  You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++    a) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by the+    Corresponding Source fixed on a durable physical medium+    customarily used for software interchange.++    b) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by a+    written offer, valid for at least three years and valid for as+    long as you offer spare parts or customer support for that product+    model, to give anyone who possesses the object code either (1) a+    copy of the Corresponding Source for all the software in the+    product that is covered by this License, on a durable physical+    medium customarily used for software interchange, for a price no+    more than your reasonable cost of physically performing this+    conveying of source, or (2) access to copy the+    Corresponding Source from a network server at no charge.++    c) Convey individual copies of the object code with a copy of the+    written offer to provide the Corresponding Source.  This+    alternative is allowed only occasionally and noncommercially, and+    only if you received the object code with such an offer, in accord+    with subsection 6b.++    d) Convey the object code by offering access from a designated+    place (gratis or for a charge), and offer equivalent access to the+    Corresponding Source in the same way through the same place at no+    further charge.  You need not require recipients to copy the+    Corresponding Source along with the object code.  If the place to+    copy the object code is a network server, the Corresponding Source+    may be on a different server (operated by you or a third party)+    that supports equivalent copying facilities, provided you maintain+    clear directions next to the object code saying where to find the+    Corresponding Source.  Regardless of what server hosts the+    Corresponding Source, you remain obligated to ensure that it is+    available for as long as needed to satisfy these requirements.++    e) Convey the object code using peer-to-peer transmission, provided+    you inform other peers where the object code and Corresponding+    Source of the work are being offered to the general public at no+    charge under subsection 6d.++  A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++  A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling.  In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage.  For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product.  A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++  "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source.  The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++  If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information.  But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++  The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed.  Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++  Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++  7. Additional Terms.++  "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law.  If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++  When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it.  (Additional permissions may be written to require their own+removal in certain cases when you modify the work.)  You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++  Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++    a) Disclaiming warranty or limiting liability differently from the+    terms of sections 15 and 16 of this License; or++    b) Requiring preservation of specified reasonable legal notices or+    author attributions in that material or in the Appropriate Legal+    Notices displayed by works containing it; or++    c) Prohibiting misrepresentation of the origin of that material, or+    requiring that modified versions of such material be marked in+    reasonable ways as different from the original version; or++    d) Limiting the use for publicity purposes of names of licensors or+    authors of the material; or++    e) Declining to grant rights under trademark law for use of some+    trade names, trademarks, or service marks; or++    f) Requiring indemnification of licensors and authors of that+    material by anyone who conveys the material (or modified versions of+    it) with contractual assumptions of liability to the recipient, for+    any liability that these contractual assumptions directly impose on+    those licensors and authors.++  All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10.  If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term.  If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++  If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++  Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++  8. Termination.++  You may not propagate or modify a covered work except as expressly+provided under this License.  Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++  However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++  Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++  Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License.  If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++  9. Acceptance Not Required for Having Copies.++  You are not required to accept this License in order to receive or+run a copy of the Program.  Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance.  However,+nothing other than this License grants you permission to propagate or+modify any covered work.  These actions infringe copyright if you do+not accept this License.  Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++  10. Automatic Licensing of Downstream Recipients.++  Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License.  You are not responsible+for enforcing compliance by third parties with this License.++  An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations.  If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++  You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License.  For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++  11. Patents.++  A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based.  The+work thus licensed is called the contributor's "contributor version".++  A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version.  For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++  Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++  In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement).  To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++  If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients.  "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++  If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++  A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License.  You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++  Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++  12. No Surrender of Others' Freedom.++  If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License.  If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all.  For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++  13. Remote Network Interaction; Use with the GNU General Public License.++  Notwithstanding any other provision of this License, if you modify the+Program, your modified version must prominently offer all users+interacting with it remotely through a computer network (if your version+supports such interaction) an opportunity to receive the Corresponding+Source of your version by providing access to the Corresponding Source+from a network server at no charge, through some standard or customary+means of facilitating copying of software.  This Corresponding Source+shall include the Corresponding Source for any work covered by version 3+of the GNU General Public License that is incorporated pursuant to the+following paragraph.++  Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU General Public License into a single+combined work, and to convey the resulting work.  The terms of this+License will continue to apply to the part which is the covered work,+but the work with which it is combined will remain governed by version+3 of the GNU General Public License.++  14. Revised Versions of this License.++  The Free Software Foundation may publish revised and/or new versions of+the GNU Affero General Public License from time to time.  Such new versions+will be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++  Each version is given a distinguishing version number.  If the+Program specifies that a certain numbered version of the GNU Affero General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation.  If the Program does not specify a version number of the+GNU Affero General Public License, you may choose any version ever published+by the Free Software Foundation.++  If the Program specifies that a proxy can decide which future+versions of the GNU Affero General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++  Later license versions may give you additional or different+permissions.  However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++  15. Disclaimer of Warranty.++  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++  16. Limitation of Liability.++  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++  17. Interpretation of Sections 15 and 16.++  If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++                     END OF TERMS AND CONDITIONS++            How to Apply These Terms to Your New Programs++  If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++  To do so, attach the following notices to the program.  It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    This program is free software: you can redistribute it and/or modify+    it under the terms of the GNU Affero General Public License as published by+    the Free Software Foundation, either version 3 of the License, or+    (at your option) any later version.++    This program is distributed in the hope that it will be useful,+    but WITHOUT ANY WARRANTY; without even the implied warranty of+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+    GNU Affero General Public License for more details.++    You should have received a copy of the GNU Affero General Public License+    along with this program.  If not, see <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++  If your software can interact with users remotely through a computer+network, you should also make sure that it provides a way for users to+get its source.  For example, if your program is a web application, its+interface could display a "Source" link that leads users to an archive+of the code.  There are many ways you could offer source, and different+solutions will be better for different programs; see section 13 for the+specific requirements.++  You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU AGPL, see+<http://www.gnu.org/licenses/>.

@@ -0,0 +1,29 @@+Copyright (c) 2009, IIJ Innovation Institute Inc.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++  * Redistributions of source code must retain the above copyright+    notice, this list of conditions and the following disclaimer.+  * Redistributions in binary form must reproduce the above copyright+    notice, this list of conditions and the following disclaimer in+    the documentation and/or other materials provided with the+    distribution.+  * Neither the name of the copyright holders nor the names of its+    contributors may be used to endorse or promote products derived+    from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS+FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.

@@ -1,3 +1,12 @@+2015-08-14 v5.3.0.0+	* Re-license majority of code under the AGPL-3+	* Add support for GHC 7.10 and Cabal 1.22+	* Remove `cabalDependPackages', `cabalAllTargets'+	* Merge #434, Fix finding sandbox config file and directory.+	* Merge #431, Re-add output line separator global option for expand command.+	* Merge #470, Support for overriding the package-db stack+	* Merge #486, Fix ineffective cache invalidation for `find`+ 2014-12-31 v5.2.1.2 	* Merge #377, Fix `browse` erroneously thinking haskell2010 identifiers 	  are operators

@@ -1,29 +1,6 @@-Copyright (c) 2009, IIJ Innovation Institute Inc.-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions-are met:--  * Redistributions of source code must retain the above copyright-    notice, this list of conditions and the following disclaimer.-  * Redistributions in binary form must reproduce the above copyright-    notice, this list of conditions and the following disclaimer in-    the documentation and/or other materials provided with the-    distribution.-  * Neither the name of the copyright holders nor the names of its-    contributors may be used to endorse or promote products derived-    from this software without specific prior written permission.+ghc-mod was originally licensed under the BSD3 but the primary license has been+changed to the AGPL3, files originally contributed under the BSD3 license remain+under this license and can generally be identified by the lack of a GPL header. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS-FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE-COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,-INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,-BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;-LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER-CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT-LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN-ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE-POSSIBILITY OF SUCH DAMAGE.+See the files COPYING.BSD3 and COPYING.AGPL3 in the source distribution for+copies of the two licenses.

@@ -3,15 +3,22 @@ module Language.Haskell.GhcMod (   -- * Cradle     Cradle(..)+  , ProjectType(..)   , findCradle   -- * Options   , Options(..)   , LineSeparator(..)   , OutputStyle(..)   , defaultOptions+  -- * Logging+  , GmLogLevel+  , increaseLogLevel+  , decreaseLogLevel+  , gmSetLogLevel+  , gmLog   -- * Types   , ModuleString-  , Expression+  , Expression(..)   , GhcPkgDb   , Symbol   , SymbolDb@@ -22,12 +29,14 @@   -- * Monad utilities   , runGhcModT   , withOptions+  , dropSession   -- * 'GhcMod' utilities   , boot   , browse   , check   , checkSyntax   , debugInfo+  , componentInfo   , expandTemplate   , info   , lint@@ -47,6 +56,13 @@   -- * SymbolDb   , loadSymbolDb   , isOutdated+  -- * Output+  , gmPutStr+  , gmErrStr+  , gmPutStrLn+  , gmErrStrLn+  , gmUnsafePutStrLn+  , gmUnsafeErrStrLn   ) where  import Language.Haskell.GhcMod.Boot@@ -61,7 +77,10 @@ import Language.Haskell.GhcMod.Info import Language.Haskell.GhcMod.Lang import Language.Haskell.GhcMod.Lint-import Language.Haskell.GhcMod.Monad+import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Modules+import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.PkgDoc import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.Target+import Language.Haskell.GhcMod.Output

@@ -1,6 +1,7 @@ module Language.Haskell.GhcMod.Boot where  import Control.Applicative+import Prelude import Language.Haskell.GhcMod.Browse import Language.Haskell.GhcMod.Flag import Language.Haskell.GhcMod.Lang@@ -9,8 +10,9 @@  -- | Printing necessary information for front-end booting. boot :: IOish m => GhcModT m String-boot =  concat <$> sequence [modules, languages, flags,-                             concat <$> mapM browse preBrowsedModules]+boot = concat <$> sequence ms+  where+    ms = [modules, languages, flags, concat <$> mapM browse preBrowsedModules]  preBrowsedModules :: [String] preBrowsedModules = [

@@ -2,54 +2,57 @@     browse   ) where -import Control.Applicative ((<$>))+import Control.Applicative import Control.Exception (SomeException(..))-import Data.Char (isAlpha)-import Data.List (sort)-import Data.Maybe (catMaybes)-import Exception (ghandle)-import FastString (mkFastString)-import GHC (GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon)+import Data.Char+import Data.List+import Data.Maybe+import FastString+import GHC import qualified GHC as G import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Doc (showPage, styleUnqualified)-import Language.Haskell.GhcMod.Gap-import Language.Haskell.GhcMod.Monad (GhcModT, options)-import Language.Haskell.GhcMod.Target (setTargetFiles)+import Language.Haskell.GhcMod.Gap as Gap+import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types import Name (getOccString)-import Outputable (ppr, Outputable)+import Outputable import TyCon (isAlgTyCon) import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy)+import Exception (ExceptionMonad, ghandle)+import Prelude  ----------------------------------------------------------------  -- | Getting functions, classes, etc from a module. --   If 'detailed' is 'True', their types are also obtained. --   If 'operators' is 'True', operators are also returned.-browse :: IOish m-       => ModuleString -- ^ A module name. (e.g. \"Data.List\")+browse :: forall m. IOish m+       => String -- ^ A module name. (e.g. \"Data.List\", "base:Prelude")        -> GhcModT m String-browse pkgmdl = convert' . sort =<< (listExports =<< getModule)+browse pkgmdl = do+    convert' . sort =<< go   where-    (mpkg,mdl) = splitPkgMdl pkgmdl+    -- TODO: Add API to Gm.Target to check if module is home module without+    -- bringing up a GHC session as well then this can be made a lot cleaner+    go = ghandle (\(SomeException _) -> return []) $ do+      goPkgModule `G.gcatch` (\(SomeException _) -> goHomeModule)++    goPkgModule = do+      opt <- options+      runGmPkgGhc $+        processExports opt =<< tryModuleInfo =<< G.findModule mdlname mpkgid++    goHomeModule = runGmlT [Right mdlname] $ do+      opt <- options+      processExports opt =<< tryModuleInfo =<< G.findModule mdlname Nothing++    tryModuleInfo m = fromJust <$> G.getModuleInfo m++    (mpkg, mdl) = splitPkgMdl pkgmdl     mdlname = G.mkModuleName mdl     mpkgid = mkFastString <$> mpkg-    listExports Nothing       = return []-    listExports (Just mdinfo) = processExports mdinfo-    -- findModule works only for package modules, moreover,-    -- you cannot load a package module. On the other hand,-    -- to browse a local module you need to load it first.-    -- If CmdLineError is signalled, we assume the user-    -- tried browsing a local module.-    getModule = browsePackageModule `G.gcatch` fallback `G.gcatch` handler-    browsePackageModule = G.findModule mdlname mpkgid >>= G.getModuleInfo-    browseLocalModule = ghandle handler $ do-      setTargetFiles [mdl]-      G.findModule mdlname Nothing >>= G.getModuleInfo-    fallback (CmdLineError _) = browseLocalModule-    fallback _                = return Nothing-    handler (SomeException _) = return Nothing+ -- | -- -- >>> splitPkgMdl "base:Prelude"@@ -57,9 +60,10 @@ -- >>> splitPkgMdl "Prelude" -- (Nothing,"Prelude") splitPkgMdl :: String -> (Maybe String,String)-splitPkgMdl pkgmdl = case break (==':') pkgmdl of-    (mdl,"")    -> (Nothing,mdl)-    (pkg,_:mdl) -> (Just pkg,mdl)+splitPkgMdl pkgmdl =+  case break (==':') pkgmdl of+    (mdl, "")    -> (Nothing, mdl)+    (pkg, _:mdl) -> (Just pkg, mdl)  -- Haskell 2010: -- small -> ascSmall | uniSmall | _@@ -71,22 +75,23 @@ isNotOp (h:_) = isAlpha h || (h == '_') isNotOp _ = error "isNotOp" -processExports :: IOish m => ModuleInfo -> GhcModT m [String]-processExports minfo = do-  opt <- options+processExports :: (G.GhcMonad m, MonadIO m, ExceptionMonad m)+               => Options -> ModuleInfo -> m [String]+processExports opt minfo = do   let     removeOps       | operators opt = id       | otherwise = filter (isNotOp . getOccString)   mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo -showExport :: IOish m => Options -> ModuleInfo -> Name -> GhcModT m String+showExport :: forall m. (G.GhcMonad m, MonadIO m, ExceptionMonad m)+           => Options -> ModuleInfo -> Name -> m String showExport opt minfo e = do   mtype' <- mtype   return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype']   where     mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` qualified opt-    mtype :: IOish m => GhcModT m (Maybe String)+    mtype :: m (Maybe String)     mtype       | detailed opt = do         tyInfo <- G.modInfoLookupName minfo e@@ -101,8 +106,9 @@       | null nm    = error "formatOp"       | isNotOp nm = nm       | otherwise  = "(" ++ nm ++ ")"-    inOtherModule :: IOish m => Name -> GhcModT m (Maybe TyThing)-    inOtherModule nm = G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm+    inOtherModule :: Name -> m (Maybe TyThing)+    inOtherModule nm = do+      G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm     justIf :: a -> Bool -> Maybe a     justIf x True = Just x     justIf _ False = Nothing@@ -127,7 +133,7 @@       && not (G.isClassTyCon typ) = Just "data"     | G.isNewTyCon typ            = Just "newtype"     | G.isClassTyCon typ          = Just "class"-    | G.isSynTyCon typ            = Just "type"+    | Gap.isSynTyCon typ          = Just "type"     | otherwise                   = Nothing  removeForAlls :: Type -> Type

@@ -1,45 +0,0 @@--- Copyright   :  Isaac Jones 2003-2004-{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}----- | ComponentLocalBuildInfo for Cabal <= 1.16-module Language.Haskell.GhcMod.Cabal16 (-    ComponentLocalBuildInfo-  , componentPackageDeps-  ) where--import Distribution.Package (InstalledPackageId, PackageIdentifier)---- From Cabal <= 1.16-data ComponentLocalBuildInfo = ComponentLocalBuildInfo {-    componentPackageDeps :: [(InstalledPackageId, PackageIdentifier)]-  }-  deriving (Read, Show)

@@ -1,58 +0,0 @@--- Copyright   :  Isaac Jones 2003-2004-{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}---- | ComponentLocalBuildInfo for Cabal >= 1.18-module Language.Haskell.GhcMod.Cabal18 (-    ComponentLocalBuildInfo-  , componentPackageDeps-  , componentLibraries-  ) where--import Distribution.Package (InstalledPackageId, PackageId)--data LibraryName = LibraryName String-    deriving (Read, Show)--data ComponentLocalBuildInfo-  = LibComponentLocalBuildInfo {-    componentPackageDeps :: [(InstalledPackageId, PackageId)],-    componentLibraries :: [LibraryName]-  }-  | ExeComponentLocalBuildInfo {-    componentPackageDeps :: [(InstalledPackageId, PackageId)]-  }-  | TestComponentLocalBuildInfo {-    componentPackageDeps :: [(InstalledPackageId, PackageId)]-  }-  | BenchComponentLocalBuildInfo {-    componentPackageDeps :: [(InstalledPackageId, PackageId)]-  }-  deriving (Read, Show)

@@ -1,73 +0,0 @@--- Copyright   :  Isaac Jones 2003-2004-{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Isaac Jones nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}---- | ComponentLocalBuildInfo for Cabal >= 1.21-module Language.Haskell.GhcMod.Cabal21 (-    ComponentLocalBuildInfo-  , PackageIdentifier(..)-  , PackageName(..)-  , componentPackageDeps-  , componentLibraries-  ) where--import Distribution.Package (InstalledPackageId)-import Data.Version (Version)--data LibraryName = LibraryName String-    deriving (Read, Show)--newtype PackageName = PackageName { unPackageName :: String }-  deriving (Read, Show)--data PackageIdentifier-  = PackageIdentifier {-    pkgName :: PackageName,-    pkgVersion :: Version-  }-  deriving (Read, Show)--type PackageId = PackageIdentifier--data ComponentLocalBuildInfo-  = LibComponentLocalBuildInfo {-    componentPackageDeps :: [(InstalledPackageId, PackageId)],-    componentLibraries :: [LibraryName]-  }-  | ExeComponentLocalBuildInfo {-    componentPackageDeps :: [(InstalledPackageId, PackageId)]-  }-  | TestComponentLocalBuildInfo {-    componentPackageDeps :: [(InstalledPackageId, PackageId)]-  }-  | BenchComponentLocalBuildInfo {-    componentPackageDeps :: [(InstalledPackageId, PackageId)]-  }-  deriving (Read, Show)

@@ -1,193 +0,0 @@-{-# LANGUAGE OverloadedStrings, CPP #-}--module Language.Haskell.GhcMod.CabalApi (-    getCompilerOptions-  , parseCabalFile-  , cabalAllBuildInfo-  , cabalDependPackages-  , cabalSourceDirs-  , cabalAllTargets-  , cabalConfigDependencies-  ) where--import Language.Haskell.GhcMod.CabalConfig-import Language.Haskell.GhcMod.Error-import Language.Haskell.GhcMod.Gap (benchmarkBuildInfo, benchmarkTargets,-                                    toModuleString)-import Language.Haskell.GhcMod.GhcPkg-import Language.Haskell.GhcMod.Types--import MonadUtils (liftIO)-import Control.Applicative ((<$>))-import qualified Control.Exception as E-import Control.Monad (filterM)-import Data.Maybe (maybeToList)-import Data.Set (fromList, toList)-import Distribution.Package (Dependency(Dependency)-                           , PackageName(PackageName))-import qualified Distribution.Package as C-import Distribution.PackageDescription (PackageDescription, BuildInfo, TestSuite, TestSuiteInterface(..), Executable)-import qualified Distribution.PackageDescription as P-import Distribution.PackageDescription.Configuration (finalizePackageDescription)-import Distribution.PackageDescription.Parse (readPackageDescription)-import Distribution.Simple.Compiler (CompilerId(..), CompilerFlavor(..))-import Distribution.Simple.Program as C (ghcProgram)-import Distribution.Simple.Program.Types (programName, programFindVersion)-import Distribution.System (buildPlatform)-import Distribution.Text (display)-import Distribution.Verbosity (silent)-import Distribution.Version (Version)-import System.Directory (doesFileExist)-import System.FilePath ((</>))--------------------------------------------------------------------- | Getting necessary 'CompilerOptions' from three information sources.-getCompilerOptions :: (IOish m, MonadError GhcModError m)-                   => [GHCOption]-                   -> Cradle-                   -> PackageDescription-                   -> m CompilerOptions-getCompilerOptions ghcopts cradle pkgDesc = do-    gopts <- liftIO $ getGHCOptions ghcopts cradle rdir $ head buildInfos-    depPkgs <- cabalConfigDependencies cradle (C.packageId pkgDesc)-    return $ CompilerOptions gopts idirs depPkgs-  where-    wdir       = cradleCurrentDir cradle-    rdir       = cradleRootDir    cradle-    buildInfos = cabalAllBuildInfo pkgDesc-    idirs      = includeDirectories rdir wdir $ cabalSourceDirs buildInfos--------------------------------------------------------------------- Include directories for modules--cabalBuildDirs :: [FilePath]-cabalBuildDirs = ["dist/build", "dist/build/autogen"]--includeDirectories :: FilePath -> FilePath -> [FilePath] -> [FilePath]-includeDirectories cdir wdir dirs = uniqueAndSort (extdirs ++ [cdir,wdir])-  where-    extdirs = map expand $ dirs ++ cabalBuildDirs-    expand "."    = cdir-    expand subdir = cdir </> subdir---------------------------------------------------------------------- | Parse a cabal file and return a 'PackageDescription'.-parseCabalFile :: (IOish m, MonadError GhcModError m)-               => Cradle-               -> FilePath-               -> m PackageDescription-parseCabalFile cradle file = do-    cid <- liftIO getGHCId-    epgd <- liftIO $ readPackageDescription silent file-    flags <- cabalConfigFlags cradle-    case toPkgDesc cid flags epgd of-        Left deps    -> fail $ show deps ++ " are not installed"-        Right (pd,_) -> if nullPkg pd-                        then fail $ file ++ " is broken"-                        else return pd-  where-    toPkgDesc cid flags =-        finalizePackageDescription flags (const True) buildPlatform cid []-    nullPkg pd = name == ""-      where-        PackageName name = C.pkgName (P.package pd)--------------------------------------------------------------------getGHCOptions :: [GHCOption] -> Cradle -> FilePath -> BuildInfo -> IO [GHCOption]-getGHCOptions ghcopts cradle rdir binfo = do-    cabalCpp <- cabalCppOptions rdir-    let cpps = map ("-optP" ++) $ P.cppOptions binfo ++ cabalCpp-    return $ ghcopts ++ pkgDb ++ exts ++ [lang] ++ libs ++ libDirs ++ cpps-  where-    pkgDb = ghcDbStackOpts $ cradlePkgDbStack cradle-    lang = maybe "-XHaskell98" (("-X" ++) . display) $ P.defaultLanguage binfo-    libDirs = map ("-L" ++) $ P.extraLibDirs binfo-    exts = map (("-X" ++) . display) $ P.usedExtensions binfo-    libs = map ("-l" ++) $ P.extraLibs binfo--cabalCppOptions :: FilePath -> IO [String]-cabalCppOptions dir = do-    exist <- doesFileExist cabalMacro-    return $ if exist then-        ["-include", cabalMacro]-      else-        []-  where-    cabalMacro = dir </> "dist/build/autogen/cabal_macros.h"---------------------------------------------------------------------- | Extracting all 'BuildInfo' for libraries, executables, and tests.-cabalAllBuildInfo :: PackageDescription -> [BuildInfo]-cabalAllBuildInfo pd = libBI ++ execBI ++ testBI ++ benchBI-  where-    libBI   = map P.libBuildInfo       $ maybeToList $ P.library pd-    execBI  = map P.buildInfo          $ P.executables pd-    testBI  = map P.testBuildInfo      $ P.testSuites pd-    benchBI = benchmarkBuildInfo pd---------------------------------------------------------------------- | Extracting package names of dependency.-cabalDependPackages :: [BuildInfo] -> [PackageBaseName]-cabalDependPackages bis = uniqueAndSort pkgs-  where-    pkgs = map getDependencyPackageName $ concatMap P.targetBuildDepends bis-    getDependencyPackageName (Dependency (PackageName nm) _) = nm---------------------------------------------------------------------- | Extracting include directories for modules.-cabalSourceDirs :: [BuildInfo] -> [IncludeDir]-cabalSourceDirs bis = uniqueAndSort $ concatMap P.hsSourceDirs bis--------------------------------------------------------------------uniqueAndSort :: [String] -> [String]-uniqueAndSort = toList . fromList--------------------------------------------------------------------getGHCId :: IO CompilerId-getGHCId = CompilerId GHC <$> getGHC--getGHC :: IO Version-getGHC = do-    mv <- programFindVersion C.ghcProgram silent (programName C.ghcProgram)-    case mv of-      -- TODO: MonadError it up-        Nothing -> E.throwIO $ userError "ghc not found"-        Just v  -> return v---------------------------------------------------------------------- | Extracting all 'Module' 'FilePath's for libraries, executables,--- tests and benchmarks.-cabalAllTargets :: PackageDescription -> IO ([String],[String],[String],[String])-cabalAllTargets pd = do-    exeTargets  <- mapM getExecutableTarget $ P.executables pd-    testTargets <- mapM getTestTarget $ P.testSuites pd-    return (libTargets,concat exeTargets,concat testTargets,benchTargets)-  where-    lib = case P.library pd of-            Nothing -> []-            Just l -> P.libModules l--    libTargets = map toModuleString lib-    benchTargets = benchmarkTargets pd--    getTestTarget :: TestSuite -> IO [String]-    getTestTarget ts =-       case P.testInterface ts of-        (TestSuiteExeV10 _ filePath) -> do-          let maybeTests = [p </> e | p <- P.hsSourceDirs $ P.testBuildInfo ts, e <- [filePath]]-          liftIO $ filterM doesFileExist maybeTests-        (TestSuiteLibV09 _ moduleName) -> return [toModuleString moduleName]-        (TestSuiteUnsupported _)       -> return []--    getExecutableTarget :: Executable -> IO [String]-    getExecutableTarget exe = do-      let maybeExes = [p </> e | p <- P.hsSourceDirs $ P.buildInfo exe, e <- [P.modulePath exe]]-      liftIO $ filterM doesFileExist maybeExes

@@ -1,171 +0,0 @@-{-# LANGUAGE RecordWildCards, CPP #-}---- | This module facilitates extracting information from Cabal's on-disk--- 'LocalBuildInfo' (@dist/setup-config@).-module Language.Haskell.GhcMod.CabalConfig (-    CabalConfig-  , cabalConfigDependencies-  , cabalConfigFlags-  ) where--import Language.Haskell.GhcMod.Error-import Language.Haskell.GhcMod.GhcPkg-import Language.Haskell.GhcMod.PathsAndFiles-import Language.Haskell.GhcMod.Read-import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Utils-import Language.Haskell.GhcMod.World--import qualified Language.Haskell.GhcMod.Cabal16 as C16-import qualified Language.Haskell.GhcMod.Cabal18 as C18-import qualified Language.Haskell.GhcMod.Cabal21 as C21--#ifndef MIN_VERSION_mtl-#define MIN_VERSION_mtl(x,y,z) 1-#endif--import Control.Applicative ((<$>))-import Control.Monad (void, mplus, when)-#if MIN_VERSION_mtl(2,2,1)-import Control.Monad.Except ()-#else-import Control.Monad.Error ()-#endif-import Data.List (find,tails,isPrefixOf,isInfixOf,nub,stripPrefix)-import Distribution.Package (InstalledPackageId(..)-                           , PackageIdentifier(..)-                           , PackageName(..))-import Distribution.PackageDescription (FlagAssignment)-import Distribution.Simple.LocalBuildInfo (ComponentName)-import MonadUtils (liftIO)---------------------------------------------------------------------- | 'Show'ed cabal 'LocalBuildInfo' string-type CabalConfig = String---- | Get contents of the file containing 'LocalBuildInfo' data. If it doesn't--- exist run @cabal configure@ i.e. configure with default options like @cabal--- build@ would do.-getConfig :: (IOish m, MonadError GhcModError m)-          => Cradle-          -> m CabalConfig-getConfig cradle = do-    outOfDate <- liftIO $ isSetupConfigOutOfDate cradle-    when outOfDate configure-    liftIO (readFile file) `tryFix` \_ ->-        configure `modifyError'` GMECabalConfigure- where-   file = setupConfigFile cradle-   prjDir = cradleRootDir cradle--   configure :: (IOish m, MonadError GhcModError m) => m ()-   configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"]---- | Get list of 'Package's needed by all components of the current package-cabalConfigDependencies :: (IOish m, MonadError GhcModError m)-                        => Cradle-                        -> PackageIdentifier-                        -> m [Package]-cabalConfigDependencies cradle thisPkg =-    configDependencies thisPkg <$> getConfig cradle---- | Extract list of depencenies for all components from 'CabalConfig'-configDependencies :: PackageIdentifier -> CabalConfig -> [Package]-configDependencies thisPkg config = map fromInstalledPackageId deps- where-    deps :: [InstalledPackageId]-    deps = case deps21 `mplus` deps18 `mplus` deps16 of-        Right ps -> ps-        Left msg -> error msg--    -- True if this dependency is an internal one (depends on the library-    -- defined in the same package).-    internal pkgid = pkgid == thisPkg--    -- Cabal >= 1.21-    deps21 :: Either String [InstalledPackageId]-    deps21 =-        map fst-      <$> filterInternal21-      <$> (readEither =<< extractField config "componentsConfigs")--    filterInternal21-        :: [(ComponentName, C21.ComponentLocalBuildInfo, [ComponentName])]-        -> [(InstalledPackageId, C21.PackageIdentifier)]--    filterInternal21 ccfg = [ (ipkgid, pkgid)-                          | (_,clbi,_)      <- ccfg-                          , (ipkgid, pkgid) <- C21.componentPackageDeps clbi-                          , not (internal . packageIdentifierFrom21 $ pkgid) ]--    packageIdentifierFrom21 :: C21.PackageIdentifier -> PackageIdentifier-    packageIdentifierFrom21 (C21.PackageIdentifier (C21.PackageName myName) myVersion) =-        PackageIdentifier (PackageName myName) myVersion--    -- Cabal >= 1.18 && < 1.21-    deps18 :: Either String [InstalledPackageId]-    deps18 =-          map fst-      <$> filterInternal-      <$> (readEither =<< extractField config "componentsConfigs")--    filterInternal-        :: [(ComponentName, C18.ComponentLocalBuildInfo, [ComponentName])]-        -> [(InstalledPackageId, PackageIdentifier)]--    filterInternal ccfg = [ (ipkgid, pkgid)-                          | (_,clbi,_)      <- ccfg-                          , (ipkgid, pkgid) <- C18.componentPackageDeps clbi-                          , not (internal pkgid) ]--    -- Cabal 1.16 and below-    deps16 :: Either String [InstalledPackageId]-    deps16 = map fst <$> filter (not . internal . snd) . nub <$> do-        cbi <- concat <$> sequence [ extract "executableConfigs"-                                   , extract "testSuiteConfigs"-                                   , extract "benchmarkConfigs" ]-                        :: Either String [(String, C16.ComponentLocalBuildInfo)]--        return $ maybe [] C16.componentPackageDeps libraryConfig-              ++ concatMap (C16.componentPackageDeps . snd) cbi-     where-       libraryConfig :: Maybe C16.ComponentLocalBuildInfo-       libraryConfig = do-         field <- find ("libraryConfig" `isPrefixOf`) (tails config)-         clbi <- stripPrefix " = " field-         if "Nothing" `isPrefixOf` clbi-             then Nothing-             else case readMaybe =<< stripPrefix "Just " clbi of-                    Just x -> x-                    Nothing -> error $ "reading libraryConfig failed\n" ++ show (stripPrefix "Just " clbi)--       extract :: String -> Either String [(String, C16.ComponentLocalBuildInfo)]-       extract field = readConfigs field <$> extractField config field--       readConfigs :: String -> String -> [(String, C16.ComponentLocalBuildInfo)]-       readConfigs f s = case readEither s of-           Right x -> x-           Left msg -> error $ "reading config " ++ f ++ " failed ("++msg++")"---- | Get the flag assignment from the local build info of the given cradle-cabalConfigFlags :: (IOish m, MonadError GhcModError m)-                 => Cradle-                 -> m FlagAssignment-cabalConfigFlags cradle = do-  config <- getConfig cradle-  case configFlags config of-    Right x  -> return x-    Left msg -> throwError (GMECabalFlags (GMEString msg))---- | Extract the cabal flags from the 'CabalConfig'-configFlags :: CabalConfig -> Either String FlagAssignment-configFlags config = readEither =<< flip extractField "configConfigurationsFlags" =<< extractField config "configFlags"---- | Find @field@ in 'CabalConfig'. Returns 'Left' containing a user readable--- error message with lots of context on failure.-extractField :: CabalConfig -> String -> Either String String-extractField config field =-    case extractParens <$> find (field `isPrefixOf`) (tails config) of-        Just f -> Right f-        Nothing -> Left $ "extractField: failed extracting "++field++" from input, input contained `"++field++"'? " ++ show (field `isInfixOf` config)

@@ -0,0 +1,228 @@+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP #-}+module Language.Haskell.GhcMod.CabalHelper+#ifndef SPEC+  ( getComponents+  , getGhcMergedPkgOptions+  , getCabalPackageDbStack+  , getCustomPkgDbStack+  , prepareCabalHelper+  )+#endif+  where++import Control.Applicative+import Control.Monad+import Control.Category ((.))+import Data.Maybe+import Data.Monoid+import Data.Serialize (Serialize)+import Data.Traversable+import Distribution.Helper+import qualified Language.Haskell.GhcMod.Types as T+import Language.Haskell.GhcMod.Types hiding (ghcProgram, ghcPkgProgram,+                                             cabalProgram)+import Language.Haskell.GhcMod.Monad.Types+import Language.Haskell.GhcMod.Utils+import Language.Haskell.GhcMod.PathsAndFiles+import Language.Haskell.GhcMod.Logging+import Language.Haskell.GhcMod.Output+import System.FilePath+import Prelude hiding ((.))++import Paths_ghc_mod as GhcMod++-- | Only package related GHC options, sufficient for things that don't need to+-- access home modules+getGhcMergedPkgOptions :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m)+  => m [GHCOption]+getGhcMergedPkgOptions = chCached Cached {+  cacheLens = Just (lGmcMergedPkgOptions . lGmCaches),+  cacheFile = mergedPkgOptsCacheFile,+  cachedAction = \ _tcf (progs, rootdir, distdir, _) _ma -> do+    readProc <- gmReadProcess+    opts <- withCabal $ runQuery'' readProc progs rootdir distdir $+                ghcMergedPkgOptions+    return ([setupConfigPath], opts)+ }++getCabalPackageDbStack :: (IOish m, GmEnv m, GmState m, GmLog m) => m [GhcPkgDb]+getCabalPackageDbStack = chCached Cached {+  cacheLens = Just (lGmcPackageDbStack . lGmCaches),+  cacheFile = pkgDbStackCacheFile,+  cachedAction = \ _tcf (progs, rootdir, distdir, _) _ma -> do+    readProc <- gmReadProcess+    dbs <- withCabal $ map chPkgToGhcPkg <$> runQuery'' readProc progs rootdir distdir packageDbStack+    return ([setupConfigPath, sandboxConfigFile], dbs)+ }++chPkgToGhcPkg :: ChPkgDb -> GhcPkgDb+chPkgToGhcPkg ChPkgGlobal = GlobalDb+chPkgToGhcPkg ChPkgUser = UserDb+chPkgToGhcPkg (ChPkgSpecific f) = PackageDb f++-- | Primary interface to cabal-helper and intended single entrypoint to+-- constructing 'GmComponent's+--+-- The Component\'s 'gmcHomeModuleGraph' will be empty and has to be resolved by+-- 'resolveGmComponents'.+getComponents :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m)+              => m [GmComponent 'GMCRaw ChEntrypoint]+getComponents = chCached Cached {+    cacheLens = Just (lGmcComponents . lGmCaches),+    cacheFile = cabalHelperCacheFile,+    cachedAction = \ _tcf (progs, rootdir, distdir, _vers) _ma -> do+      readProc <- gmReadProcess+      runQuery'' readProc progs rootdir distdir $ do+        q <- join7+               <$> ghcOptions+               <*> ghcPkgOptions+               <*> ghcSrcOptions+               <*> ghcLangOptions+               <*> entrypoints+               <*> entrypoints+               <*> sourceDirs+        let cs = flip map q $ curry8 (GmComponent mempty)+        return ([setupConfigPath], cs)+  }+ where+   curry8 fn (a, (b, (c, (d, (e, (f, (g, h))))))) = fn a b c d e f g h++   join7 a b c d e f = join' a . join' b . join' c . join' d . join' e . join' f+   join' :: Eq a => [(a,b)] -> [(a,c)] -> [(a,(b,c))]+   join' lb lc = [ (a, (b, c))+                 | (a, b)  <- lb+                 , (a', c) <- lc+                 , a == a'+                 ]++prepareCabalHelper :: (IOish m, GmEnv m, GmLog m) => m ()+prepareCabalHelper = do+  crdl <- cradle+  let projdir = cradleRootDir crdl+      distdir = projdir </> "dist"+  readProc <- gmReadProcess+  when (cradleProjectType crdl == CabalProject) $+       withCabal $ liftIO $ prepare readProc projdir distdir++parseCustomPackageDb :: String -> [GhcPkgDb]+parseCustomPackageDb src = map parsePkgDb $ filter (not . null) $ lines src+ where+   parsePkgDb "global" = GlobalDb+   parsePkgDb "user" = UserDb+   parsePkgDb s = PackageDb s++getCustomPkgDbStack :: (IOish m, GmEnv m) => m (Maybe [GhcPkgDb])+getCustomPkgDbStack = do+    mCusPkgDbFile <- liftIO . (traverse readFile <=< findCustomPackageDbFile) . cradleRootDir =<< cradle+    return $ parseCustomPackageDb <$> mCusPkgDbFile++withCabal :: (IOish m, GmEnv m, GmLog m) => m a -> m a+withCabal action = do+    crdl <- cradle+    opts <- options+    readProc <- gmReadProcess++    let projdir = cradleRootDir crdl+        distdir = projdir </> "dist"++    mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl+    mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl)++    mCusPkgDbStack <- getCustomPkgDbStack++    pkgDbStackOutOfSync <-+         case mCusPkgDbStack of+           Just cusPkgDbStack -> do+             pkgDb <- runQuery'' readProc (helperProgs opts) projdir distdir $+                 map chPkgToGhcPkg <$> packageDbStack+             return $ pkgDb /= cusPkgDbStack++           Nothing -> return False++    cusPkgStack <- maybe [] ((PackageDb "clear"):) <$> getCustomPkgDbStack++    --TODO: also invalidate when sandboxConfig file changed++    when (isSetupConfigOutOfDate mCabalFile mCabalConfig) $+      gmLog GmDebug "" $ strDoc $ "setup configuration is out of date, reconfiguring Cabal project."+    when pkgDbStackOutOfSync $+      gmLog GmDebug "" $ strDoc $ "package-db stack out of sync with ghc-mod.package-db-stack, reconfiguring Cabal project."++    when (isSetupConfigOutOfDate mCabalFile mCabalConfig || pkgDbStackOutOfSync) $+        withDirectory_ (cradleRootDir crdl) $ do+            let progOpts =+                    [ "--with-ghc=" ++ T.ghcProgram opts ]+                    -- Only pass ghc-pkg if it was actually set otherwise we+                    -- might break cabal's guessing logic+                    ++ if T.ghcPkgProgram opts /= T.ghcPkgProgram defaultOptions+                         then [ "--with-ghc-pkg=" ++ T.ghcPkgProgram opts ]+                         else []+                    ++ map pkgDbArg cusPkgStack+            liftIO $ void $ readProc (T.cabalProgram opts) ("configure":progOpts) ""+            gmLog GmDebug "" $ strDoc $ "writing Cabal autogen files"+            liftIO $ writeAutogenFiles readProc projdir distdir+    action++pkgDbArg :: GhcPkgDb -> String+pkgDbArg GlobalDb      = "--package-db=global"+pkgDbArg UserDb        = "--package-db=user"+pkgDbArg (PackageDb p) = "--package-db=" ++ p++-- * Neither file exists -> should return False:+--   @Nothing < Nothing = False@+--   (since we don't need to @cabal configure@ when no cabal file exists.)+--+-- * Cabal file doesn't exist (unlikely case) -> should return False+--   @Just cc < Nothing = False@+--   TODO: should we delete dist/setup-config?+--+-- * dist/setup-config doesn't exist yet -> should return True:+--   @Nothing < Just cf = True@+--+-- * Both files exist+--   @Just cc < Just cf = cc < cf = cc `olderThan` cf@+isSetupConfigOutOfDate :: Maybe TimedFile -> Maybe TimedFile -> Bool+isSetupConfigOutOfDate worldCabalFile worldCabalConfig = do+  worldCabalConfig < worldCabalFile+++helperProgs :: Options -> Programs+helperProgs opts = Programs {+                            cabalProgram  = T.cabalProgram opts,+                            ghcProgram    = T.ghcProgram opts,+                            ghcPkgProgram = T.ghcPkgProgram opts+                          }++chCached :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m, Serialize a)+  => Cached m GhcModState ChCacheData a -> m a+chCached c = do+  root <- cradleRootDir <$> cradle+  d <- cacheInputData root+  withCabal $ cached root c d+ where+   cacheInputData root = do+               opt <- options+               return $ ( helperProgs opt+                        , root+                        , root </> "dist"+                        , (gmVer, chVer)+                        )++   gmVer = GhcMod.version+   chVer = VERSION_cabal_helper

@@ -0,0 +1,103 @@+{-# LANGUAGE OverloadedStrings #-}+module Language.Haskell.GhcMod.Caching (+    module Language.Haskell.GhcMod.Caching+  , module Language.Haskell.GhcMod.Caching.Types+  ) where++import Control.Arrow (first)+import Control.Monad+import Control.Monad.Trans.Maybe+import Data.Maybe+import Data.Serialize (Serialize, encode, decode)+import Data.Version+import Data.Label+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import System.FilePath+import Utils (TimedFile(..), timeMaybe, mightExist)+import Paths_ghc_mod (version)++import Language.Haskell.GhcMod.Monad.Types+import Language.Haskell.GhcMod.Caching.Types+import Language.Haskell.GhcMod.Logging++-- | Cache a MonadIO action with proper invalidation.+cached :: forall m a d. (Gm m, MonadIO m, Serialize a, Eq d, Serialize d, Show d)+       => FilePath -- ^ Directory to prepend to 'cacheFile'+       -> Cached m GhcModState d a -- ^ Cache descriptor+       -> d+       -> m a+cached dir cd d = do+    mcc <- readCache+    tcfile <- liftIO $ timeMaybe (cacheFile cd)+    case mcc of+      Nothing ->+          writeCache (TimedCacheFiles tcfile []) Nothing "cache missing or unreadable"+      Just (ifs, d', a) | d /= d' -> do+          tcf <- timeCacheInput dir (cacheFile cd) ifs+          writeCache tcf (Just a) $ "input data changed" -- ++ "   was: " ++ show d ++ "  is: " ++ show d'+      Just (ifs, _, a) -> do+          tcf <- timeCacheInput dir (cacheFile cd) ifs+          case invalidatingInputFiles tcf of+            Just [] -> return a+            Just _  -> writeCache tcf (Just a) "input files changed"+            Nothing -> writeCache tcf (Just a) "cache missing, existed a sec ago WTF?"++ where+   cacheHeader = BS8.pack $ "Written by ghc-mod " ++ showVersion version ++ "\n"++   writeCache tcf ma cause = do+     (ifs', a) <- (cachedAction cd) tcf d ma+     gmLog GmDebug "" $ (text "regenerating cache") <+>: text (cacheFile cd)+                                                    <+> parens (text cause)+     case cacheLens cd of+       Nothing -> return ()+       Just label -> do+         gmLog GmDebug "" $ (text "writing memory cache") <+>: text (cacheFile cd)+         setLabel label $ Just (ifs', d, a)++     liftIO $ BS.writeFile (dir </> cacheFile cd) $+         BS.append cacheHeader $ encode (ifs', d, a)+     return a++   setLabel l x = do+     s <- gmsGet+     gmsPut $ set l x s++   readCache :: m (Maybe ([FilePath], d, a))+   readCache = runMaybeT $ do+       case cacheLens cd of+         Just label -> do+             c <- MaybeT (get label `liftM` gmsGet) `mplus` readCacheFromFile+             setLabel label $ Just c+             return c+         Nothing ->+             readCacheFromFile++   readCacheFromFile = do+         f <- MaybeT $ liftIO $ mightExist $ cacheFile cd+         readCacheFromFile' f++   readCacheFromFile' f = MaybeT $ do+     gmLog GmDebug "" $ (text "reading cache") <+>: text (cacheFile cd)+     cc <- liftIO $ BS.readFile f+     case first BS8.words $ BS8.span (/='\n') cc of+       (["Written", "by", "ghc-mod", ver], rest)+           | BS8.unpack ver == showVersion version ->+            return $ either (const Nothing) Just $ decode $ BS.drop 1 rest+       _ -> return Nothing++timeCacheInput :: MonadIO m => FilePath -> FilePath -> [FilePath] -> m TimedCacheFiles+timeCacheInput dir cfile ifs = liftIO $ do+    -- TODO: is checking the times this way around race free?+    ins <- (timeMaybe . (dir </>)) `mapM` ifs+    mtcfile <- timeMaybe cfile+    return $ TimedCacheFiles mtcfile (catMaybes ins)++invalidatingInputFiles :: TimedCacheFiles -> Maybe [FilePath]+invalidatingInputFiles tcf =+    case tcCacheFile tcf of+      Nothing -> Nothing+      Just tcfile -> Just $ map tfPath $+                     -- get input files older than tcfile+                     filter (tcfile<) $ tcFiles tcf

@@ -0,0 +1,52 @@+module Language.Haskell.GhcMod.Caching.Types where++import Utils+import Data.Label+import Data.Version+import Distribution.Helper++type CacheContents d a = Maybe ([FilePath], d, a)+type CacheLens s d a = s :-> CacheContents d a++data Cached m s d a = Cached {+  cacheFile       :: FilePath,+  cacheLens       :: Maybe (CacheLens s d a),+  cachedAction    :: TimedCacheFiles+                  -> d+                  -> Maybe a+                  -> m ([FilePath], a)++  -- ^ @cachedAction tcf data ma@+  --+  -- * @tcf@: Input file timestamps. Not technically necessary, just an+  -- optimizazion when knowing which input files changed can make updating the+  -- cache faster+  --+  -- * @data@: Arbitrary static input data to cache action. Can be used to+  -- invalidate the cache using something other than file timestamps+  -- i.e. environment tool version numbers+  --+  -- * @ma@: Cached data if it existed+  --+  -- Returns:+  --+  -- * @fst@: Input files used in generating the cache+  --+  -- * @snd@: Cache data, will be stored alongside the static input data in the+  --   'cacheFile'+  --+  -- The cached action, will only run if one of the following is true:+  --+  -- * 'cacheFile' doesn\'t exist yet+  -- * 'cacheFile' exists and 'inputData' changed+  -- * any files returned by the cached action changed+ }++data TimedCacheFiles = TimedCacheFiles {+  tcCacheFile :: Maybe TimedFile,+  -- ^ 'cacheFile' timestamp+  tcFiles     :: [TimedFile]+  -- ^ Timestamped files returned by the cached action+ }++type ChCacheData = (Programs, FilePath, FilePath, (Version, [Char]))

@@ -8,17 +8,24 @@ import Data.Maybe (isJust) import qualified Data.Text as T import qualified Data.Text.IO as T (readFile)+import System.FilePath+ import qualified DataCon as Ty-import Exception (ghandle, SomeException(..)) import GHC (GhcMonad, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) import qualified GHC as G+import Outputable (PprStyle)+import qualified TyCon as Ty+import qualified Type as Ty+import Exception+ import Language.Haskell.GhcMod.Convert+import Language.Haskell.GhcMod.DynFlags import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.SrcUtils-import Outputable (PprStyle)-import qualified TyCon as Ty-import qualified Type as Ty+import Language.Haskell.GhcMod.Doc+import Language.Haskell.GhcMod.Logging+import Language.Haskell.GhcMod.Types  ---------------------------------------------------------------- -- CASE SPLITTING@@ -38,23 +45,29 @@        -> Int          -- ^ Line number.        -> Int          -- ^ Column number.        -> GhcModT m String-splits file lineNo colNo = ghandle handler body-  where-    body = inModuleContext file $ \dflag style -> do-        opt <- options-        modSum <- Gap.fileModSummary file-        whenFound' opt (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of-          (SplitInfo varName bndLoc (varLoc,varT) _matches) -> do-             let varName' = showName dflag style varName  -- Convert name to string-             text <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $-                                                getTyCons dflag style varName varT)-             return (fourInts bndLoc, text)-          (TySplitInfo varName bndLoc (varLoc,varT)) -> do-             let varName' = showName dflag style varName  -- Convert name to string-             text <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $-                                                getTyCons dflag style varName varT)-             return (fourInts bndLoc, text)-    handler (SomeException _) = emptyResult =<< options+splits file lineNo colNo =+  ghandle handler $ runGmlT' [Left file] deferErrors $ do+      opt <- options+      crdl <- cradle+      style <- getStyle+      dflag <- G.getSessionDynFlags+      modSum <- Gap.fileModSummary (cradleCurrentDir crdl </> file)+      whenFound' opt (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of+        (SplitInfo varName bndLoc (varLoc,varT) _matches) -> do+          let varName' = showName dflag style varName  -- Convert name to string+          t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $+                                             getTyCons dflag style varName varT)+          return (fourInts bndLoc, t)+        (TySplitInfo varName bndLoc (varLoc,varT)) -> do+          let varName' = showName dflag style varName  -- Convert name to string+          t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $+                                             getTyCons dflag style varName varT)+          return (fourInts bndLoc, t)+ where+   handler (SomeException ex) = do+     gmLog GmDebug "splits" $+           text "" $$ nest 4 (showDoc ex)+     emptyResult =<< options  ---------------------------------------------------------------- -- a. Code for getting the information of the variable@@ -79,7 +92,11 @@         varT <- Gap.getType tcm varPat'  -- Finally we get the type of the var         case varT of           Just varT' ->+#if __GLASGOW_HASKELL__ >= 710+            let (L matchL (G.Match _ _ _ (G.GRHSs rhsLs _))) = match+#else             let (L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match+#endif             in return $ Just (SplitInfo (getPatternVarName varPat') matchL varT' (map G.getLoc rhsLs) )           _ -> return Nothing @@ -178,15 +195,16 @@ ---------------------------------------------------------------- -- c. Code for performing the case splitting -genCaseSplitTextFile :: GhcMonad m => FilePath -> SplitToTextInfo -> m String+genCaseSplitTextFile :: (MonadIO m, GhcMonad m) =>+    FilePath -> SplitToTextInfo -> m String genCaseSplitTextFile file info = liftIO $ do-  text <- T.readFile file-  return $ getCaseSplitText (T.lines text) info+  t <- T.readFile file+  return $ getCaseSplitText (T.lines t) info  getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String-getCaseSplitText text (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS+getCaseSplitText t (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS                                        , sVarSpan = sVS, sTycons = sT })  =-  let bindingText = getBindingText text sBS+  let bindingText = getBindingText t sBS       difference  = srcSpanDifference sBS sVS       replaced    = map (replaceVarWithTyCon bindingText difference sVN) sT       -- The newly generated bindings need to be indented to align with the@@ -195,9 +213,9 @@    in T.unpack $ T.intercalate (T.pack "\n") (concat replaced')  getBindingText :: [T.Text] -> SrcSpan -> [T.Text]-getBindingText text srcSpan =+getBindingText t srcSpan =   let Just (sl,sc,el,ec) = Gap.getSrcSpan srcSpan-      lines_ = drop (sl - 1) $ take el text+      lines_ = drop (sl - 1) $ take el t    in if sl == el       then -- only one line            [T.drop (sc - 1) $ T.take ec $ head lines_]@@ -212,7 +230,7 @@    in (vsl - bsl, vsc - bsc, vel - bsl, vec - bsc) -- assume variable in one line  replaceVarWithTyCon :: [T.Text] -> (Int,Int,Int,Int) -> String -> String -> [T.Text]-replaceVarWithTyCon text (vsl,vsc,_,vec) varname tycon =+replaceVarWithTyCon t (vsl,vsc,_,vec) varname tycon =   let tycon'      = if ' ' `elem` tycon || ':' `elem` tycon then "(" ++ tycon ++ ")" else tycon       lengthDiff  = length tycon' - length varname       tycon''     = T.pack $ if lengthDiff < 0 then tycon' ++ replicate (-lengthDiff) ' ' else tycon'@@ -222,7 +240,7 @@                           else if n == vsl                                then T.take vsc line `T.append` tycon'' `T.append` T.drop vec line                                else T.replicate spacesToAdd (T.pack " ") `T.append` line)-              [0 ..] text+              [0 ..] t  indentBindingTo :: SrcSpan -> [T.Text] -> [T.Text] indentBindingTo bndLoc binds =

@@ -5,12 +5,12 @@   , expand   ) where -import Control.Applicative ((<$>))+import Control.Applicative+import Prelude import Language.Haskell.GhcMod.DynFlags import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Logger-import Language.Haskell.GhcMod.Monad (IOish, GhcModT)-import Language.Haskell.GhcMod.Target (setTargetFiles)+import Language.Haskell.GhcMod.Monad  ---------------------------------------------------------------- @@ -29,15 +29,12 @@ check :: IOish m       => [FilePath]  -- ^ The target files.       -> GhcModT m (Either String String)-{--check fileNames = overrideGhcUserOptions $ \ghcOpts -> do-  withLogger (setAllWarningFlags . setNoMaxRelevantBindings . Gap.setWarnTypedHoles . Gap.setDeferTypeErrors) $ do-    _ <- G.setSessionDynFlags =<< addCmdOpts ghcOpts =<< G.getSessionDynFlags-    setTargetFiles fileNames--}-check fileNames =-  withLogger (setAllWarningFlags . setNoMaxRelevantBindings) $-    setTargetFiles fileNames+check files =+    runGmlTWith+      (map Left files)+      return+      ((fmap fst <$>) . withLogger setNoMaxRelevantBindings)+      (return ())  ---------------------------------------------------------------- @@ -51,8 +48,10 @@ ----------------------------------------------------------------  -- | Expanding Haskell Template.-expand :: IOish m-       => [FilePath]  -- ^ The target files.-       -> GhcModT m (Either String String)-expand fileNames = withLogger (Gap.setDumpSplices . setNoWarningFlags) $-    setTargetFiles fileNames+expand :: IOish m => [FilePath] -> GhcModT m (Either String String)+expand files =+    runGmlTWith+      (map Left files)+      return+      ((fmap fst <$>) . withLogger (Gap.setDumpSplices . setNoWarningFlags))+      (return ())

@@ -1,11 +1,12 @@-{-# LANGUAGE FlexibleInstances, FlexibleContexts, OverlappingInstances #-}+{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-}  module Language.Haskell.GhcMod.Convert (convert, convert', emptyResult, whenFound, whenFound') where -import Language.Haskell.GhcMod.Monad+import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Types -import Control.Applicative ((<$>))+import Control.Applicative+import Prelude  type Builder = String -> String @@ -23,11 +24,11 @@ inter _ [] = id inter c bs = foldr1 (\x y -> x . (c:) . y) bs -convert' :: (ToString a, IOish m) => a -> GhcModT m String+convert' :: (ToString a, IOish m, GmEnv m) => a -> m String convert' x = flip convert x <$> options  convert :: ToString a => Options -> a -> String-convert opt@Options { outputStyle = LispStyle  } x = toLisp  opt x "\n"+convert opt@Options { outputStyle = LispStyle  } x = toLisp opt x "\n" convert opt@Options { outputStyle = PlainStyle } x   | str == "\n" = ""   | otherwise   = str@@ -35,8 +36,8 @@     str = toPlain opt x "\n"  class ToString a where-    toLisp  :: Options -> a -> Builder-    toPlain :: Options -> a -> Builder+  toLisp  :: Options -> a -> Builder+  toPlain :: Options -> a -> Builder  lineSep :: Options -> String lineSep opt = interpret lsep@@ -51,8 +52,8 @@ -- >>> toPlain defaultOptions "foo" "" -- "foo" instance ToString String where-    toLisp  opt = quote opt-    toPlain opt = replace '\n' (lineSep opt)+  toLisp  opt = quote opt+  toPlain opt = replace '\n' (lineSep opt)  -- | --@@ -61,9 +62,13 @@ -- >>> toPlain defaultOptions ["foo", "bar", "baz"] "" -- "foo\nbar\nbaz" instance ToString [String] where-    toLisp  opt = toSexp1 opt-    toPlain opt = inter '\n' . map (toPlain opt)+  toLisp  opt = toSexp1 opt+  toPlain opt = inter '\n' . map (toPlain opt) +instance ToString [ModuleString] where+  toLisp  opt = toLisp opt . map getModuleString+  toPlain opt = toPlain opt . map getModuleString+ -- | -- -- >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)]@@ -72,23 +77,23 @@ -- >>> toPlain defaultOptions inp "" -- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\"" instance ToString [((Int,Int,Int,Int),String)] where-    toLisp  opt = toSexp2 . map toS-      where-        toS x = ('(' :) . tupToString opt x . (')' :)-    toPlain opt = inter '\n' . map (tupToString opt)+  toLisp  opt = toSexp2 . map toS+    where+      toS x = ('(' :) . tupToString opt x . (')' :)+  toPlain opt = inter '\n' . map (tupToString opt)  instance ToString ((Int,Int,Int,Int),String) where-    toLisp  opt x = ('(' :) . tupToString opt x . (')' :)-    toPlain opt x = tupToString opt x+  toLisp  opt x = ('(' :) . tupToString opt x . (')' :)+  toPlain opt x = tupToString opt x  instance ToString ((Int,Int,Int,Int),[String]) where-    toLisp  opt (x,s) = ('(' :) . fourIntsToString opt x .-                        (' ' :) . toLisp opt s . (')' :)-    toPlain opt (x,s) = fourIntsToString opt x . ('\n' :) . toPlain opt s+  toLisp  opt (x,s) = ('(' :) . fourIntsToString opt x .+                      (' ' :) . toLisp opt s . (')' :)+  toPlain opt (x,s) = fourIntsToString opt x . ('\n' :) . toPlain opt s  instance ToString (String, (Int,Int,Int,Int),[String]) where-    toLisp  opt (s,x,y) = toSexp2 [toLisp opt s, ('(' :) . fourIntsToString opt x . (')' :), toLisp opt y]-    toPlain opt (s,x,y) = inter '\n' [toPlain opt s, fourIntsToString opt x, toPlain opt y]+  toLisp  opt (s,x,y) = toSexp2 [toLisp opt s, ('(' :) . fourIntsToString opt x . (')' :), toLisp opt y]+  toPlain opt (s,x,y) = inter '\n' [toPlain opt s, fourIntsToString opt x, toPlain opt y]  toSexp1 :: Options -> [String] -> Builder toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :)

@@ -1,19 +1,22 @@ module Language.Haskell.GhcMod.Cradle (     findCradle   , findCradle'-  , findCradleWithoutSandbox+  , findSpecCradle   , cleanupCradle   ) where -import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.PathsAndFiles+import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils -import Control.Exception.IOChoice ((||>))-import System.Directory (getCurrentDirectory, removeDirectoryRecursive)-import System.FilePath (takeDirectory)-+import Control.Applicative+import Control.Monad+import Control.Monad.Trans.Maybe+import Data.Maybe+import System.Directory+import System.FilePath+import Prelude  ---------------------------------------------------------------- @@ -25,51 +28,62 @@ findCradle = findCradle' =<< getCurrentDirectory  findCradle' :: FilePath -> IO Cradle-findCradle' dir = cabalCradle dir ||> sandboxCradle dir ||> plainCradle dir+findCradle' dir = run $ do+    (cabalCradle dir `mplus`  sandboxCradle dir `mplus` plainCradle dir)+ where run a = fillTempDir =<< (fromJust <$> runMaybeT a) +findSpecCradle :: FilePath -> IO Cradle+findSpecCradle dir = do+    let cfs = [cabalCradle, sandboxCradle]+    cs <- catMaybes <$> mapM (runMaybeT . ($ dir)) cfs+    gcs <- filterM isNotGmCradle cs+    fillTempDir =<< case gcs of+                      [] -> fromJust <$> runMaybeT (plainCradle dir)+                      c:_ -> return c+ where+   isNotGmCradle :: Cradle -> IO Bool+   isNotGmCradle crdl = do+     not <$> doesFileExist (cradleRootDir crdl </> "ghc-mod.cabal")+ cleanupCradle :: Cradle -> IO () cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl -cabalCradle :: FilePath -> IO Cradle+fillTempDir :: MonadIO m => Cradle -> m Cradle+fillTempDir crdl = do+  tmpDir <- liftIO $ newTempDir (cradleRootDir crdl)+  return crdl { cradleTempDir = tmpDir }++cabalCradle :: FilePath -> MaybeT IO Cradle cabalCradle wdir = do-    Just cabalFile <- findCabalFile wdir+    cabalFile <- MaybeT $ findCabalFile wdir+     let cabalDir = takeDirectory cabalFile-    pkgDbStack <- getPackageDbStack cabalDir-    tmpDir <- newTempDir cabalDir+     return Cradle {-        cradleCurrentDir = wdir+        cradleProjectType = CabalProject+      , cradleCurrentDir = wdir       , cradleRootDir    = cabalDir-      , cradleTempDir    = tmpDir+      , cradleTempDir    = error "tmpDir"       , cradleCabalFile  = Just cabalFile-      , cradlePkgDbStack = pkgDbStack       } -sandboxCradle :: FilePath -> IO Cradle+sandboxCradle :: FilePath -> MaybeT IO Cradle sandboxCradle wdir = do-    Just sbDir <- getSandboxDb wdir-    pkgDbStack <- getPackageDbStack sbDir-    tmpDir <- newTempDir sbDir+    sbDir <- MaybeT $ findCabalSandboxDir wdir     return Cradle {-        cradleCurrentDir = wdir+        cradleProjectType = SandboxProject+      , cradleCurrentDir = wdir       , cradleRootDir    = sbDir-      , cradleTempDir    = tmpDir+      , cradleTempDir    = error "tmpDir"       , cradleCabalFile  = Nothing-      , cradlePkgDbStack = pkgDbStack       } -plainCradle :: FilePath -> IO Cradle+plainCradle :: FilePath -> MaybeT IO Cradle plainCradle wdir = do-    tmpDir <- newTempDir wdir-    return Cradle {-        cradleCurrentDir = wdir+    return $ Cradle {+        cradleProjectType = PlainProject+      , cradleCurrentDir = wdir       , cradleRootDir    = wdir-      , cradleTempDir    = tmpDir+      , cradleTempDir    = error "tmpDir"       , cradleCabalFile  = Nothing-      , cradlePkgDbStack = [GlobalDb, UserDb]       }---- Just for testing-findCradleWithoutSandbox :: IO Cradle-findCradleWithoutSandbox = do-    cradle <- findCradle-    return cradle { cradlePkgDbStack = [GlobalDb]} -- FIXME

@@ -1,39 +1,127 @@-module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo) where+module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo, componentInfo) where -import Control.Applicative ((<$>))-import Data.List (intercalate)-import Data.Maybe (isJust, fromJust)+import Control.Arrow (first)+import Control.Applicative+import Control.Monad+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Char+import Data.List.Split+import Text.PrettyPrint import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Internal+import Language.Haskell.GhcMod.Target+import Language.Haskell.GhcMod.Pretty+import Language.Haskell.GhcMod.Utils  ----------------------------------------------------------------  -- | Obtaining debug information. debugInfo :: IOish m => GhcModT m String-debugInfo = cradle >>= \c -> convert' =<< do-    CompilerOptions gopts incDir pkgs <--        if isJust $ cradleCabalFile c then-            fromCabalFile c ||> simpleCompilerOption-          else-            simpleCompilerOption-    return [-        "Root directory:      " ++ cradleRootDir c-      , "Current directory:   " ++ cradleCurrentDir c-      , "Cabal file:          " ++ show (cradleCabalFile c)-      , "GHC options:         " ++ unwords gopts-      , "Include directories: " ++ unwords incDir-      , "Dependent packages:  " ++ intercalate ", " (map showPkg pkgs)-      , "System libraries:    " ++ ghcLibDir-      ]-  where-    simpleCompilerOption = options >>= \op ->-        return $ CompilerOptions (ghcUserOptions op) [] []-    fromCabalFile c = options >>= \opts -> do-        pkgDesc <- parseCabalFile c $ fromJust $ cradleCabalFile c-        getCompilerOptions (ghcUserOptions opts) c pkgDesc+debugInfo = do+    Options {..} <- options+    Cradle {..} <- cradle +    cabal <-+        case cradleProjectType of+          CabalProject -> cabalDebug+          _ -> return []++    pkgOpts <- packageGhcOptions++    return $ unlines $+      [ "Root directory:       " ++ cradleRootDir+      , "Current directory:    " ++ cradleCurrentDir+      , "GHC Package flags:\n"   ++ render (nest 4 $+              fsep $ map text pkgOpts)+      , "GHC System libraries: " ++ ghcLibDir+      , "GHC user options:\n"    ++ render (nest 4 $+              fsep $ map text ghcUserOptions)+      ] ++ cabal++cabalDebug :: IOish m => GhcModT m [String]+cabalDebug = do+    Cradle {..} <- cradle+    mcs <- cabalResolvedComponents+    let entrypoints = Map.map gmcEntrypoints mcs+        graphs      = Map.map gmcHomeModuleGraph mcs+        opts        = Map.map gmcGhcOpts mcs+        srcOpts     = Map.map gmcGhcSrcOpts mcs++    return $+         [ "Cabal file:           " ++ show cradleCabalFile+         , "Cabal entrypoints:\n"       ++ render (nest 4 $+              mapDoc gmComponentNameDoc smpDoc entrypoints)+         , "Cabal components:\n"        ++ render (nest 4 $+              mapDoc gmComponentNameDoc graphDoc graphs)+         , "GHC Cabal options:\n"       ++ render (nest 4 $+              mapDoc gmComponentNameDoc (fsep . map text) opts)+         , "GHC search path options:\n" ++ render (nest 4 $+              mapDoc gmComponentNameDoc (fsep . map text) srcOpts)+         ]++componentInfo :: IOish m => [String] -> GhcModT m String+componentInfo ts = do+    -- TODO: most of this is copypasta of targetGhcOptions. Factor out more+    -- useful function from there.+    crdl <- cradle+    sefnmn <- Set.fromList `liftM` mapM guessModuleFile ts+    mcs <- cabalResolvedComponents+    let+        mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn+        candidates = findCandidates $ map snd mdlcs+        cn = pickComponent candidates+    opts <- targetGhcOptions crdl sefnmn++    return $ unlines $+         [ "Matching Components:\n"     ++ render (nest 4 $+              alistDoc (either text mnDoc) (setDoc gmComponentNameDoc) mdlcs)+         , "Picked Component:\n"        ++ render (nest 4 $+              gmComponentNameDoc cn)+         , "GHC Cabal options:\n"       ++ render (nest 4 $ fsep $ map text opts)+         ]+ where+   zipMap f l = l `zip` (f `map` l)++guessModuleFile :: MonadIO m => String -> m (Either FilePath ModuleName)+guessModuleFile m+  | (isUpper . head .&&. (all $ all $ isAlphaNum .||. (=='.')) . splitOn ".") m =+      return $ Right $ mkModuleName m+ where+   infixr 1 .||.+   infixr 2 .&&.+   (.||.) = liftA2 (||)+   (.&&.) = liftA2 (&&)++guessModuleFile str = Left `liftM` liftIO (canonFilePath str)++graphDoc :: GmModuleGraph -> Doc+graphDoc GmModuleGraph{..} =+    mapDoc mpDoc smpDoc' gmgGraph+ where+   smpDoc' smp = vcat $ map mpDoc' $ Set.toList smp+   mpDoc' = text . moduleNameString . mpModule++setDoc :: (a -> Doc) -> Set.Set a -> Doc+setDoc f s = vcat $ map f $ Set.toList s++smpDoc :: Set.Set ModulePath -> Doc+smpDoc smp = setDoc mpDoc smp++mpDoc :: ModulePath -> Doc+mpDoc (ModulePath mn fn) = text (moduleNameString mn) <+> parens (text fn)++mnDoc :: ModuleName -> Doc+mnDoc mn = text (moduleNameString mn)++alistDoc :: Ord k => (k -> Doc) -> (a -> Doc) -> [(k, a)] -> Doc+alistDoc fk fa alist = mapDoc fk fa (Map.fromList alist)++mapDoc :: (k -> Doc) -> (a -> Doc) -> Map.Map k a -> Doc+mapDoc kd ad m = vcat $+    map (uncurry ($+$)) $ map (first kd) $ Map.toList $ Map.map (nest 4 . ad) m ----------------------------------------------------------------  -- | Obtaining root information.

@@ -1,9 +1,8 @@ module Language.Haskell.GhcMod.Doc where -import GHC (DynFlags, GhcMonad)-import qualified GHC as G+import GHC import Language.Haskell.GhcMod.Gap (withStyle, showDocWith)-import Outputable (SDoc, PprStyle, mkUserStyle, Depth(AllTheWay), neverQualify)+import Outputable import Pretty (Mode(..))  showPage :: DynFlags -> PprStyle -> SDoc -> String@@ -12,9 +11,14 @@ showOneLine :: DynFlags -> PprStyle -> SDoc -> String showOneLine dflag style = showDocWith dflag OneLineMode . withStyle dflag style +-- showForUser :: DynFlags -> PrintUnqualified -> SDoc -> String+-- showForUser dflags unqual sdoc =+--     showDocWith dflags PageMode $+--       runSDoc sdoc $ initSDocContext dflags $ mkUserStyle unqual AllTheWay+ getStyle :: GhcMonad m => m PprStyle getStyle = do-    unqual <- G.getPrintUnqual+    unqual <- getPrintUnqual     return $ mkUserStyle unqual AllTheWay  styleUnqualified :: PprStyle

@@ -2,7 +2,7 @@  module Language.Haskell.GhcMod.DynFlags where -import Control.Applicative ((<$>))+import Control.Applicative import Control.Monad (void) import GHC (DynFlags(..), GhcMode(..), GhcLink(..), HscTarget(..)) import qualified GHC as G@@ -11,8 +11,7 @@ import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Types import System.IO.Unsafe (unsafePerformIO)--data Build = CabalPkg | SingleFile deriving Eq+import Prelude  setEmptyLogger :: DynFlags -> DynFlags setEmptyLogger df = Gap.setLogAction df $ \_ _ _ _ _ -> return ()@@ -41,37 +40,15 @@   , optLevel  = 0   } -setIncludeDirs :: [IncludeDir] -> DynFlags -> DynFlags-setIncludeDirs idirs df = df { importPaths = idirs }--setBuildEnv :: Build -> DynFlags -> DynFlags-setBuildEnv build = setHideAllPackages build . setCabalPackage build---- | With ghc-7.8 this option simply makes GHC print a message suggesting users--- add hiddend packages to the build-depends field in their cabal file when the--- user tries to import a module form a hidden package.-setCabalPackage :: Build -> DynFlags -> DynFlags-setCabalPackage CabalPkg df = Gap.setCabalPkg df-setCabalPackage _ df = df---- | Enable hiding of all package not explicitly exposed (like Cabal does)-setHideAllPackages :: Build -> DynFlags -> DynFlags-setHideAllPackages CabalPkg df = Gap.setHideAllPackages df-setHideAllPackages _ df = df- -- | Parse command line ghc options and add them to the 'DynFlags' passed addCmdOpts :: GhcMonad m => [GHCOption] -> DynFlags -> m DynFlags addCmdOpts cmdOpts df =-    tfst <$> G.parseDynamicFlags df (map G.noLoc cmdOpts)+    fst3 <$> G.parseDynamicFlags df (map G.noLoc cmdOpts)   where-    tfst (a,_,_) = a+    fst3 (a,_,_) = a  ---------------------------------------------------------------- --- | Return the 'DynFlags' currently in use in the GHC session.-getDynamicFlags :: IO DynFlags-getDynamicFlags = G.runGhc (Just libdir) G.getSessionDynFlags- withDynFlags :: GhcMonad m              => (DynFlags -> DynFlags)              -> m a@@ -119,3 +96,7 @@ #else setNoMaxRelevantBindings = id #endif++deferErrors :: DynFlags -> Ghc DynFlags+deferErrors df = return $+  Gap.setWarnTypedHoles $ Gap.setDeferTypeErrors $ setNoWarningFlags df

@@ -1,67 +1,173 @@-{-# LANGUAGE TypeFamilies, ScopedTypeVariables, DeriveDataTypeable #-}+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE ExistentialQuantification #-} module Language.Haskell.GhcMod.Error (     GhcModError(..)+  , GMConfigStateFileError(..)+  , GmError   , gmeDoc+  , ghcExceptionDoc+  , liftMaybe+  , overrideError   , modifyError   , modifyError'+  , modifyGmError   , tryFix+  , GHandler(..)+  , gcatches   , module Control.Monad.Error-  , module Exception+  , module Control.Exception   ) where -import Control.Monad.Error (MonadError(..), Error(..))+import Control.Arrow+import Control.Exception+import Control.Monad.Error hiding (MonadIO, liftIO)+import qualified Data.Set as Set import Data.List-import Data.Typeable-import Exception+import Data.Version+import System.Process (showCommandForUser) import Text.PrettyPrint+import Text.Printf -data GhcModError = GMENoMsg-                 -- ^ Unknown error-                 | GMEString String-                 -- ^ Some Error with a message. These are produced mostly by-                 -- 'fail' calls on GhcModT.-                 | GMEIOException IOException-                 -- ^ IOExceptions captured by GhcModT's MonadIO instance-                 | GMECabalConfigure GhcModError-                 -- ^ Configuring a cabal project failed.-                 | GMECabalFlags GhcModError-                 -- ^ Retrieval of the cabal configuration flags failed.-                 | GMEProcess [String] GhcModError-                 -- ^ Launching an operating system process failed. The first-                 -- field is the command.-                 | GMENoCabalFile-                 -- ^ No cabal file found.-                 | GMETooManyCabalFiles [FilePath]-                 -- ^ Too many cabal files found.-                   deriving (Eq,Show,Typeable)+import Exception+import Panic+import Config (cProjectVersion, cHostPlatformString)+import Paths_ghc_mod (version) -instance Exception GhcModError+import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.Pretty -instance Error GhcModError where-    noMsg = GMENoMsg-    strMsg = GMEString+type GmError m = MonadError GhcModError m +gmCsfeDoc :: GMConfigStateFileError -> Doc+gmCsfeDoc GMConfigStateFileNoHeader = text $+        "Saved package config file header is missing. "+        ++ "Try re-running the 'configure' command."++gmCsfeDoc GMConfigStateFileBadHeader = text $+        "Saved package config file header is corrupt. "+        ++ "Try re-running the 'configure' command."++gmCsfeDoc GMConfigStateFileNoParse = text $+        "Saved package config file body is corrupt. "+        ++ "Try re-running the 'configure' command."++gmCsfeDoc GMConfigStateFileMissing = text $+    "Run the 'configure' command first."++-- gmCsfeDoc (ConfigStateFileBadVersion oldCabal oldCompiler _) = text $+--         "You need to re-run the 'configure' command. "+--         ++ "The version of Cabal being used has changed (was "+--         ++ display oldCabal ++ ", now "+--         ++ display currentCabalId ++ ")."+--         ++ badCompiler+--       where+--         badCompiler+--           | oldCompiler == currentCompilerId = ""+--           | otherwise =+--               " Additionally the compiler is different (was "+--               ++ display oldCompiler ++ ", now "+--               ++ display currentCompilerId+--               ++ ") which is probably the cause of the problem."+ gmeDoc :: GhcModError -> Doc gmeDoc e = case e of     GMENoMsg ->         text "Unknown error"     GMEString msg ->         text msg-    GMEIOException ioe ->-        text $ show ioe     GMECabalConfigure msg ->-        text "cabal configure failed: " <> gmeDoc msg+        text "Configuring cabal project failed: " <> gmeDoc msg     GMECabalFlags msg ->-        text "retrieval of the cabal configuration flags failed: " <> gmeDoc msg-    GMEProcess cmd msg ->-        text ("launching operating system process `"++unwords cmd++"` failed: ")-          <> gmeDoc msg+        text "Retrieval of the cabal configuration flags failed: " <> gmeDoc msg+    GMECabalComponent cn ->+        text "Cabal component " <> quotes (gmComponentNameDoc cn)+                                <> text " could not be found."+    GMECabalCompAssignment ctx ->+        text "Could not find a consistent component assignment for modules:" $$+          (nest 4 $ foldr ($+$) empty $ map ctxDoc ctx) $$+        text "" $$+        (if all (Set.null . snd) ctx+           then noComponentSuggestions+           else empty) $$+        text "- To find out which components ghc-mod knows about try:" $$+            nest 4 (backticks $ text "ghc-mod debug")++      where+        noComponentSuggestions =+          text "- Are some of these modules part of a test and or benchmark?\+               \ Try enabling them:" $$+              nest 4 (backticks $ text "cabal configure --enable-tests [--enable-benchmarks]")++        backticks d = char '`' <> d <> char '`'+        ctxDoc = moduleDoc *** compsDoc+                 >>> first (<> colon) >>> uncurry (flip hang 4)++        moduleDoc (Left fn)   =+            text "File " <> quotes (text fn)+        moduleDoc (Right mdl) =+            text "Module " <> quotes (text $ moduleNameString mdl)++        compsDoc sc | Set.null sc = text "has no known components"+        compsDoc sc = fsep $ punctuate comma $+                        map gmComponentNameDoc $ Set.toList sc++    GMEProcess cmd args emsg -> let c = showCommandForUser cmd args in+        case emsg of+          Right err ->+             text (printf "Launching system command `%s` failed: " c)+                  <> gmeDoc err+          Left (_out, _err, rv) -> text $+             printf "Launching system command `%s` failed (exited with %d)" c rv     GMENoCabalFile ->         text "No cabal file found."     GMETooManyCabalFiles cfs ->         text $ "Multiple cabal files found. Possible cabal files: \""                ++ intercalate "\", \"" cfs ++"\"."+    GMECabalStateFile csfe ->+        gmCsfeDoc csfe +ghcExceptionDoc :: GhcException -> Doc+ghcExceptionDoc e@(CmdLineError _) =+    text $ "<command line>: " ++ showGhcException e ""+ghcExceptionDoc (UsageError str) = strDoc str+ghcExceptionDoc (Panic msg) = vcat $ map text $ lines $ printf "\+\GHC panic! (the 'impossible' happened)\n\+\  ghc-mod version %s\n\+\  GHC library version %s for %s:\n\+\       %s\n\+\\n\+\Please report this as a bug: %s\n"+    gmVer ghcVer platform msg url+ where+   gmVer = showVersion version+   ghcVer = cProjectVersion+   platform = cHostPlatformString+   url = "https://github.com/kazu-yamamoto/ghc-mod/issues" :: String++ghcExceptionDoc e = text $ showGhcException e ""+++liftMaybe :: MonadError e m => e -> m (Maybe a) -> m a+liftMaybe e action = maybe (throwError e) return =<< action++overrideError :: MonadError e m => e -> m a -> m a+overrideError e action = modifyError (const e) action+ modifyError :: MonadError e m => (e -> e) -> m a -> m a modifyError f action = action `catchError` \e -> throwError $ f e @@ -69,6 +175,24 @@ modifyError' :: MonadError e m => m a -> (e -> e) -> m a modifyError' = flip modifyError ++modifyGmError :: (MonadIO m, ExceptionMonad m)+              => (GhcModError -> GhcModError) -> m a -> m a+modifyGmError f a = gcatch a $ \(ex :: GhcModError) -> liftIO $ throwIO (f ex)+ tryFix :: MonadError e m => m a -> (e -> m ()) -> m a-tryFix action fix = do-  action `catchError` \e -> fix e >> action+tryFix action f = do+  action `catchError` \e -> f e >> action++data GHandler m a = forall e . Exception e => GHandler (e -> m a)++gcatches :: (MonadIO m, ExceptionMonad m) => m a -> [GHandler m a] -> m a+gcatches io handlers = io `gcatch` gcatchesHandler handlers++gcatchesHandler :: (MonadIO m, ExceptionMonad m)+    => [GHandler m a] -> SomeException -> m a+gcatchesHandler handlers e = foldr tryHandler (liftIO $ throw e) handlers+    where tryHandler (GHandler handler) res+              = case fromException e of+                Just e' -> handler e'+                Nothing -> res

@@ -11,7 +11,8 @@ import Data.Function (on) import Data.List (find, nub, sortBy) import qualified Data.Map as M-import Data.Maybe (isJust, catMaybes)+import Data.Maybe (catMaybes)+import Text.PrettyPrint (($$), text, nest) import Exception (ghandle, SomeException(..)) import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags,             SrcSpan, Type, GenLocated(L))@@ -19,8 +20,12 @@ import qualified Name as G import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Convert+import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.SrcUtils+import Language.Haskell.GhcMod.Logging (gmLog)+import Language.Haskell.GhcMod.Pretty (showDoc)+import Language.Haskell.GhcMod.Doc import Language.Haskell.GhcMod.Types import Outputable (PprStyle) import qualified Type as Ty@@ -31,6 +36,10 @@ import qualified Language.Haskell.Exts.Annotated as HE import Djinn.GHC +#if __GLASGOW_HASKELL__ >= 710+import GHC (unLoc)+#endif+ ---------------------------------------------------------------- -- INTIAL CODE FROM FUNCTION OR INSTANCE SIGNATURE ----------------------------------------------------------------@@ -62,22 +71,27 @@     -> Int          -- ^ Line number.     -> Int          -- ^ Column number.     -> GhcModT m String-sig file lineNo colNo = ghandle handler body-  where-    body = inModuleContext file $ \dflag style -> do-        opt <- options-        modSum <- Gap.fileModSummary file-        whenFound opt (getSignature modSum lineNo colNo) $ \s -> case s of+sig file lineNo colNo =+    runGmlT' [Left file] deferErrors $ ghandle fallback $ do+      opt <- options+      style <- getStyle+      dflag <- G.getSessionDynFlags+      modSum <- Gap.fileModSummary file+      whenFound opt (getSignature modSum lineNo colNo) $ \s ->+        case s of           Signature loc names ty ->-            ("function", fourInts loc, map (initialBody dflag style ty) names)+              ("function", fourInts loc, map (initialBody dflag style ty) names)+           InstanceDecl loc cls ->-             ("instance", fourInts loc, map (\x -> initialBody dflag style (G.idType x) x)-                                            (Ty.classMethods cls))+            let body x = initialBody dflag style (G.idType x) x+            in ("instance", fourInts loc, body `map` Ty.classMethods cls)+           TyFamDecl loc name flavour vars ->             let (rTy, initial) = initialTyFamString flavour-             in (rTy, fourInts loc, [initial ++ initialFamBody dflag style name vars])--    handler (SomeException _) = do+                body = initialFamBody dflag style name vars+            in (rTy, fourInts loc, [initial ++ body])+  where+    fallback (SomeException _) = do       opt <- options       -- Code cannot be parsed by ghc module       -- Fallback: try to get information via haskell-src-exts@@ -97,7 +111,11 @@     p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum     -- Inspect the parse tree to find the signature     case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsDecl G.RdrName] of+#if __GLASGOW_HASKELL__ >= 710+      [L loc (G.SigD (Ty.TypeSig names (L _ ty) _))] ->+#else       [L loc (G.SigD (Ty.TypeSig names (L _ ty)))] ->+#endif         -- We found a type signature         return $ Just $ Signature loc (map G.unLoc names) ty       [L _ (G.InstD _)] -> do@@ -125,9 +143,14 @@                         G.TypeFamily -> Open                         G.DataFamily -> Data #endif-#if __GLASGOW_HASKELL__ >= 706++#if __GLASGOW_HASKELL__ >= 710             getTyFamVarName x = case x of                 L _ (G.UserTyVar n)     -> n+                L _ (G.KindedTyVar (G.L _ n) _) -> n+#elif __GLASGOW_HASKELL__ >= 706+            getTyFamVarName x = case x of+                L _ (G.UserTyVar n)     -> n                 L _ (G.KindedTyVar n _) -> n #else             getTyFamVarName x = case x of  -- In GHC 7.4, HsTyVarBndr's have an extra arg@@ -144,7 +167,8 @@                       return $ InstanceDecl loc cls  -- Get signature from haskell-src-exts-getSignatureFromHE :: GhcMonad m => FilePath -> Int -> Int -> m (Maybe HESigInfo)+getSignatureFromHE :: (MonadIO m, GhcMonad m) =>+    FilePath -> Int -> Int -> m (Maybe HESigInfo) getSignatureFromHE file lineNo colNo = do   presult <- liftIO $ HE.parseFile file   return $ case presult of@@ -220,9 +244,11 @@ initialHead1 fname args elts =   case initialBodyArgs1 args elts of     []      -> fname-    arglist -> if isSymbolName fname-               then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)-               else fname ++ " " ++ unwords arglist+    arglist+      | isSymbolName fname ->+        head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)+      | otherwise ->+        fname ++ " " ++ unwords arglist  initialBodyArgs1 :: [FnArg] -> [String] -> [String] initialBodyArgs1 args elts = take (length args) elts@@ -238,12 +264,24 @@  instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where   getFnName dflag style name = showOccName dflag style $ Gap.occName name-  getFnArgs (G.HsForAllTy _ _ _ (L _ iTy))  = getFnArgs iTy+#if __GLASGOW_HASKELL__ >= 710+  getFnArgs (G.HsForAllTy _ _ _ _ (L _ iTy))+#else+  getFnArgs (G.HsForAllTy _ _ _ (L _ iTy))+#endif+    = getFnArgs iTy+   getFnArgs (G.HsParTy (L _ iTy))           = getFnArgs iTy   getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) =       (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy     where fnarg ty = case ty of-              (G.HsForAllTy _ _ _ (L _ iTy)) -> fnarg iTy+#if __GLASGOW_HASKELL__ >= 710+              (G.HsForAllTy _ _ _ _ (L _ iTy)) ->+#else+              (G.HsForAllTy _ _ _ (L _ iTy)) ->+#endif+                fnarg iTy+               (G.HsParTy (L _ iTy))          -> fnarg iTy               (G.HsFunTy _ _)                -> True               _                              -> False@@ -301,48 +339,61 @@        -> Int          -- ^ Column number.        -> Expression   -- ^ A Haskell expression.        -> GhcModT m String-refine file lineNo colNo expr = ghandle handler body+refine file lineNo colNo (Expression expr) =+  ghandle handler $+    runGmlT' [Left file] deferErrors $ do+      opt <- options+      style <- getStyle+      dflag <- G.getSessionDynFlags+      modSum <- Gap.fileModSummary file+      p <- G.parseModule modSum+      tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p+      ety <- G.exprType expr+      whenFound opt (findVar dflag style tcm tcs lineNo colNo) $+        \(loc, name, rty, paren) ->+            let eArgs = getFnArgs ety+                rArgs = getFnArgs rty+                diffArgs' = length eArgs - length rArgs+                diffArgs  = if diffArgs' < 0 then 0 else diffArgs'+                iArgs = take diffArgs eArgs+                txt = initialHead1 expr iArgs (infinitePrefixSupply name)+             in (fourInts loc, doParen paren txt)   where-    body = inModuleContext file $ \dflag style -> do-        opt <- options-        modSum <- Gap.fileModSummary file-        p <- G.parseModule modSum-        tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p-        ety <- G.exprType expr-        whenFound opt (findVar dflag style tcm tcs lineNo colNo) $-          \(loc, name, rty, paren) ->-              let eArgs = getFnArgs ety-                  rArgs = getFnArgs rty-                  diffArgs' = length eArgs - length rArgs-                  diffArgs  = if diffArgs' < 0 then 0 else diffArgs'-                  iArgs = take diffArgs eArgs-                  text = initialHead1 expr iArgs (infinitePrefixSupply name)-               in (fourInts loc, doParen paren text)--    handler (SomeException _) = emptyResult =<< options+   handler (SomeException ex) = do+     gmLog GmDebug "refining" $+           text "" $$ nest 4 (showDoc ex)+     emptyResult =<< options  -- Look for the variable in the specified position-findVar :: GhcMonad m => DynFlags -> PprStyle-                      -> G.TypecheckedModule -> G.TypecheckedSource-                      -> Int -> Int -> m (Maybe (SrcSpan, String, Type, Bool))+findVar+  :: GhcMonad m+  => DynFlags+  -> PprStyle+  -> G.TypecheckedModule+  -> G.TypecheckedSource+  -> Int+  -> Int+  -> m (Maybe (SrcSpan, String, Type, Bool)) findVar dflag style tcm tcs lineNo colNo =-  let lst = sortBy (cmp `on` G.getLoc) $-                listifySpans tcs (lineNo, colNo) :: [G.LHsExpr Id]-  in case lst of-      e@(L _ (G.HsVar i)):others ->-        do tyInfo <- Gap.getType tcm e-           let name = getFnName dflag style i-           if (name == "undefined" || head name == '_') && isJust tyInfo-              then let Just (s,t) = tyInfo-                       b = case others of  -- If inside an App, we need-                                           -- parenthesis-                             [] -> False-                             L _ (G.HsApp (L _ a1) (L _ a2)):_ ->-                               isSearchedVar i a1 || isSearchedVar i a2-                             _  -> False-                    in return $ Just (s, name, t, b)-              else return Nothing-      _ -> return Nothing+  case lst of+    e@(L _ (G.HsVar i)):others -> do+      tyInfo <- Gap.getType tcm e+      case tyInfo of+        Just (s, typ)+          | name == "undefined" || head name == '_' ->+            return $ Just (s, name, typ, b)+          where+            name = getFnName dflag style i+            -- If inside an App, we need parenthesis+            b = case others of+                  L _ (G.HsApp (L _ a1) (L _ a2)):_ ->+                    isSearchedVar i a1 || isSearchedVar i a2+                  _  -> False+        _ -> return Nothing+    _ -> return Nothing+  where+    lst :: [G.LHsExpr Id]+    lst = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo)  infinitePrefixSupply :: String -> [String] infinitePrefixSupply "undefined" = repeat "undefined"@@ -366,10 +417,11 @@      -> Int          -- ^ Line number.      -> Int          -- ^ Column number.      -> GhcModT m String-auto file lineNo colNo = ghandle handler body-  where-    body = inModuleContext file $ \dflag style -> do+auto file lineNo colNo =+  ghandle handler $ runGmlT' [Left file] deferErrors $ do         opt <- options+        style <- getStyle+        dflag <- G.getSessionDynFlags         modSum <- Gap.fileModSummary file         p <- G.parseModule modSum         tcm@TypecheckedModule {@@ -395,8 +447,11 @@           djinns <- djinn True (Just minfo) env rty (Max 10) 100000           return ( fourInts loc                  , map (doParen paren) $ nub (djinnsEmpty ++ djinns))--    handler (SomeException _) = emptyResult =<< options+ where+   handler (SomeException ex) = do+     gmLog GmDebug "auto-refining" $+           text "" $$ nest 4 (showDoc ex)+     emptyResult =<< options  -- Functions we do not want in completions notWantedFuns :: [String]@@ -443,7 +498,11 @@ #else                     :: [G.LMatch Id] #endif+#if __GLASGOW_HASKELL__ >= 710+              (L _ (G.Match _ pats _ _):_) = m+#else               (L _ (G.Match pats _ _):_) = m+#endif            in (funId, pats)         _ -> (error "This should never happen", []) @@ -478,7 +537,13 @@ getBindingsForRecPat (Ty.InfixCon (L _ a1) (L _ a2)) =     M.union (getBindingsForPat a1) (getBindingsForPat a2) getBindingsForRecPat (Ty.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) =-    getBindingsForRecFields fields- where getBindingsForRecFields [] = M.empty-       getBindingsForRecFields (Ty.HsRecField {Ty.hsRecFieldArg = (L _ a)}:fs) =-         M.union (getBindingsForPat a) (getBindingsForRecFields fs)+    getBindingsForRecFields (map unLoc' fields)+ where+#if __GLASGOW_HASKELL__ >= 710+   unLoc' = unLoc+#else+   unLoc' = id+#endif+   getBindingsForRecFields [] = M.empty+   getBindingsForRecFields (Ty.HsRecField {Ty.hsRecFieldArg = (L _ a)}:fs) =+       M.union (getBindingsForPat a) (getBindingsForRecFields fs)

@@ -1,9 +1,8 @@-{-# LANGUAGE CPP, BangPatterns #-}+{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse #-}  module Language.Haskell.GhcMod.Find #ifndef SPEC-  (-    Symbol+  ( Symbol   , SymbolDb   , loadSymbolDb   , lookupSymbol@@ -15,65 +14,51 @@ #endif   where -import Control.Applicative ((<$>))+import Control.Applicative import Control.Monad (when, void) import Data.Function (on) import Data.List (groupBy, sort)-import Data.Maybe (fromMaybe) import qualified GHC as G import Language.Haskell.GhcMod.Convert+import Language.Haskell.GhcMod.Gap (listVisibleModules) import Language.Haskell.GhcMod.Monad+import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils-import Language.Haskell.GhcMod.PathsAndFiles+import Language.Haskell.GhcMod.World (timedPackageCaches)+import Language.Haskell.GhcMod.Output import Name (getOccString)+import Module (moduleName) import System.Directory (doesFileExist, getModificationTime)-import System.FilePath ((</>), takeDirectory)+import System.FilePath ((</>)) import System.IO--#ifndef MIN_VERSION_containers-#define MIN_VERSION_containers(x,y,z) 1-#endif+import Prelude -#if MIN_VERSION_containers(0,5,0)-import Data.Map.Strict (Map)-import qualified Data.Map.Strict as M-#else import Data.Map (Map) import qualified Data.Map as M-#endif  ----------------------------------------------------------------  -- | Type of function and operation names. type Symbol = String -- | Database from 'Symbol' to \['ModuleString'\].-data SymbolDb = SymbolDb {-    table :: Map Symbol [ModuleString]-  , packageCachePath :: FilePath+data SymbolDb = SymbolDb+  { table             :: Map Symbol [ModuleString]   , symbolDbCachePath :: FilePath   } deriving (Show) -isOutdated :: SymbolDb -> IO Bool-isOutdated db = symbolDbCachePath db `isOlderThan` packageCachePath db---------------------------------------------------------------------- | When introducing incompatible changes to the 'symbolCache' file format--- increment this version number.-symbolCacheVersion :: Integer-symbolCacheVersion = 0---- | Filename of the symbol table cache file.-symbolCache :: String-symbolCache = "ghc-mod-"++ show symbolCacheVersion ++".cache"+isOutdated :: IOish m => SymbolDb -> GhcModT m Bool+isOutdated db =+  (liftIO . isOlderThan (symbolDbCachePath db)) =<< timedPackageCaches  ----------------------------------------------------------------  -- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\] --   which will be concatenated. 'loadSymbolDb' is called internally. findSymbol :: IOish m => Symbol -> GhcModT m String-findSymbol sym = loadSymbolDb >>= lookupSymbol sym+findSymbol sym = do+  tmpdir <- cradleTempDir <$> cradle+  loadSymbolDb tmpdir >>= lookupSymbol sym  -- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\] --   which will be concatenated.@@ -81,25 +66,25 @@ lookupSymbol sym db = convert' $ lookupSym sym db  lookupSym :: Symbol -> SymbolDb -> [ModuleString]-lookupSym sym db = fromMaybe [] $ M.lookup sym $ table db+lookupSym sym db = M.findWithDefault [] sym $ table db  ---------------------------------------------------------------  -- | Loading a file and creates 'SymbolDb'.-loadSymbolDb :: IOish m => GhcModT m SymbolDb-loadSymbolDb = do-    ghcMod <- liftIO ghcModExecutable-    tmpdir <- cradleTempDir <$> cradle-    file <- chop <$> readProcess' ghcMod ["dumpsym", tmpdir]-    !db <- M.fromAscList . map conv . lines <$> liftIO (readFile file)-    return $ SymbolDb {-        table = db-      , packageCachePath = takeDirectory file </> packageCache-      , symbolDbCachePath = file-      }+loadSymbolDb :: IOish m => FilePath -> GhcModT m SymbolDb+loadSymbolDb dir = do+  ghcMod <- liftIO ghcModExecutable+  readProc <- gmReadProcess+  file   <- liftIO $ chop <$> readProc ghcMod ["dumpsym", dir] ""+  !db    <- M.fromAscList . map conv . lines <$> liftIO (readFile file)+  return $ SymbolDb+    { table             = db+    , symbolDbCachePath = file+    }   where-    conv :: String -> (Symbol,[ModuleString])+    conv :: String -> (Symbol, [ModuleString])     conv = read+    chop :: String -> String     chop "" = ""     chop xs = init xs @@ -112,54 +97,52 @@  dumpSymbol :: IOish m => FilePath -> GhcModT m String dumpSymbol dir = do-    let cache = dir </> symbolCache-        pkgdb = dir </> packageCache--    create <- liftIO $ cache `isOlderThan` pkgdb-    when create $ (liftIO . writeSymbolCache cache) =<< getSymbolTable+  create <- (liftIO . isOlderThan cache) =<< timedPackageCaches+  runGmPkgGhc $ do+    when create $+      liftIO . writeSymbolCache cache =<< getGlobalSymbolTable     return $ unlines [cache]+  where+    cache = dir </> symbolCacheFile  writeSymbolCache :: FilePath-                 -> [(Symbol,[ModuleString])]+                 -> [(Symbol, [ModuleString])]                  -> IO () writeSymbolCache cache sm =   void . withFile cache WriteMode $ \hdl ->-      mapM (hPrint hdl) sm--isOlderThan :: FilePath -> FilePath -> IO Bool-isOlderThan cache file = do-    exist <- doesFileExist cache-    if not exist then-        return True-      else do-        tCache <- getModificationTime cache-        tFile <- getModificationTime file-        return $ tCache <= tFile -- including equal just in case+    mapM (hPrint hdl) sm --- | Browsing all functions in all system/user modules.-getSymbolTable :: IOish m => GhcModT m [(Symbol,[ModuleString])]-getSymbolTable = do-    ghcModules <- G.packageDbModules True-    moduleInfos <- mapM G.getModuleInfo ghcModules-    let modules = do-         m <- ghcModules-         let moduleName = G.moduleNameString $ G.moduleName m---             modulePkg = G.packageIdString $ G.modulePackageId m-         return moduleName+-- | Check whether given file is older than any file from the given set.+-- Returns True if given file does not exist.+isOlderThan :: FilePath -> [TimedFile] -> IO Bool+isOlderThan cache files = do+  exist <- doesFileExist cache+  if not exist+  then return True+  else do+    tCache <- getModificationTime cache+    return $ any (tCache <=) $ map tfTime files -- including equal just in case -    return $ collectModules-           $ extractBindings `concatMap` (moduleInfos `zip` modules)+-- | Browsing all functions in all system modules.+getGlobalSymbolTable :: LightGhc [(Symbol, [ModuleString])]+getGlobalSymbolTable = do+  df  <- G.getSessionDynFlags+  let mods = listVisibleModules df+  moduleInfos <- mapM G.getModuleInfo mods+  return $ collectModules+         $ extractBindings `concatMap` (moduleInfos `zip` mods) -extractBindings :: (Maybe G.ModuleInfo, ModuleString)+extractBindings :: (Maybe G.ModuleInfo, G.Module)                 -> [(Symbol, ModuleString)]-extractBindings (Nothing,_)  = []-extractBindings (Just inf,mdlname) =-    map (\name -> (getOccString name, mdlname)) names+extractBindings (Nothing,  _)   = []+extractBindings (Just inf, mdl) =+  map (\name -> (getOccString name, modStr)) names   where-    names = G.modInfoExports inf+    names  = G.modInfoExports inf+    modStr = ModuleString $ moduleNameString $ moduleName mdl -collectModules :: [(Symbol,ModuleString)]-               -> [(Symbol,[ModuleString])]+collectModules :: [(Symbol, ModuleString)]+               -> [(Symbol, [ModuleString])] collectModules = map tieup . groupBy ((==) `on` fst) . sort   where     tieup x = (head (map fst x), map snd x)

@@ -1,86 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--module Language.Haskell.GhcMod.GHCApi (-    ghcPkgDb-  , package-  , modules-  , findModule-  , moduleInfo-  , localModuleInfo-  , bindings-  ) where--import Language.Haskell.GhcMod.GhcPkg-import Language.Haskell.GhcMod.Monad (GhcModT)-import Language.Haskell.GhcMod.Target (setTargetFiles)-import Language.Haskell.GhcMod.Types--import Control.Applicative ((<$>))-import Distribution.Package (InstalledPackageId(..))-import qualified Data.Map as M-import GHC (DynFlags(..))-import qualified GHC as G-import GhcMonad-import qualified Packages as G-import qualified Module as G-import qualified OccName as G--------------------------------------------------------------------- get Packages,Modules,Bindings--ghcPkgDb :: GhcMonad m => m PkgDb-ghcPkgDb = M.fromList <$>-    maybe [] (map toKv . filterInternal) <$> pkgDatabase <$> G.getSessionDynFlags- where-    toKv pkg = (fromInstalledPackageId $ G.installedPackageId pkg, pkg)-    filterInternal =-        filter ((/= InstalledPackageId "builtin_rts") . G.installedPackageId)--package :: G.PackageConfig -> Package-package = fromInstalledPackageId . G.installedPackageId--modules :: G.PackageConfig -> [ModuleString]-modules = map G.moduleNameString . G.exposedModules--findModule :: ModuleString -> PkgDb -> [Package]-findModule m db = M.elems $ package `M.map` (containsModule `M.filter` db)- where-    containsModule :: G.PackageConfig -> Bool-    containsModule pkgConf =-        G.mkModuleName m `elem` G.exposedModules pkgConf---ghcPkgId :: Package -> G.PackageId-ghcPkgId (name,_,_) =-    -- TODO: Adding the package version too breaks 'findModule' for some reason-    -- this isn't a big deal since in the common case where we're in a cabal-    -- project we just use cabal's view of package dependencies anyways so we're-    -- guaranteed to only have one version of each package exposed. However when-    -- we're operating without a cabal project this will probaly cause trouble.-    G.stringToPackageId name--type Binding = String---- | @moduleInfo mpkg module@. @mpkg@ should be 'Nothing' iff. moduleInfo--- should look for @module@ in the working directory.------ To map a 'ModuleString' to a package see 'findModule'-moduleInfo :: IOish m-           => Maybe Package-           -> ModuleString-           -> GhcModT m (Maybe G.ModuleInfo)-moduleInfo mpkg mdl = do-    let mdlName = G.mkModuleName mdl-        mfsPkgId = G.packageIdFS . ghcPkgId <$> mpkg-    loadLocalModule-    G.findModule mdlName mfsPkgId >>= G.getModuleInfo- where-   loadLocalModule = case mpkg of-       Just _ -> return ()-       Nothing -> setTargetFiles [mdl]--localModuleInfo :: IOish m => ModuleString -> GhcModT m (Maybe G.ModuleInfo)-localModuleInfo mdl = moduleInfo Nothing mdl--bindings :: G.ModuleInfo -> [Binding]-bindings minfo = map (G.occNameString . G.getOccName) $ G.modInfoExports minfo

@@ -1,23 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--module Language.Haskell.GhcMod.GHCChoice where--import Control.Exception (IOException)-import CoreMonad (liftIO)-import qualified Exception as GE-import GHC (GhcMonad)---------------------------------------------------------------------- | Try the left 'Ghc' action. If 'IOException' occurs, try---   the right 'Ghc' action.-(||>) :: GhcMonad m => m a -> m a -> m a-x ||> y = x `GE.gcatch` (\(_ :: IOException) -> y)---- | Go to the next 'Ghc' monad by throwing 'AltGhcgoNext'.-goNext :: GhcMonad m => m a-goNext = liftIO . GE.throwIO $ userError "goNext"---- | Run any one 'Ghc' monad.-runAnyOne :: GhcMonad m => [m a] -> m a-runAnyOne = foldr (||>) goNext

@@ -13,7 +13,6 @@   , showSeverityCaption   , setCabalPkg   , setHideAllPackages-  , addPackageFlags   , setDeferTypeErrors   , setWarnTypedHoles   , setDumpSplices@@ -33,14 +32,15 @@   , fileModSummary   , WarnFlags   , emptyWarnFlags-  , benchmarkBuildInfo-  , benchmarkTargets-  , toModuleString   , GLMatch   , GLMatchI   , getClass   , occName-  , setFlags+  , listVisibleModuleNames+  , listVisibleModules+  , lookupModulePackageInAllPackages+  , Language.Haskell.GhcMod.Gap.isSynTyCon+  , parseModuleHeader   ) where  import Control.Applicative hiding (empty)@@ -49,15 +49,15 @@ import Data.List (intersperse) import Data.Maybe (catMaybes) import Data.Time.Clock (UTCTime)+import Data.Traversable hiding (mapM) import DataCon (dataConRepType) import Desugar (deSugarExpr) import DynFlags import ErrUtils+import Exception import FastString import GhcMonad import HscTypes-import Language.Haskell.GhcMod.GHCChoice-import Language.Haskell.GhcMod.Types import NameSet import OccName import Outputable@@ -65,8 +65,8 @@ import StringBuffer import TcType import Var (varType)+import System.Directory -import qualified Distribution.PackageDescription as P import qualified InstEnv import qualified Pretty import qualified StringBuffer as SB@@ -88,11 +88,24 @@ import RdrName (rdrNameOcc) #endif +#if __GLASGOW_HASKELL__ < 710+import UniqFM (eltsUFM)+import Module+#endif+ #if __GLASGOW_HASKELL__ >= 704 import qualified Data.IntSet as I (IntSet, empty)-import qualified Distribution.ModuleName as M (ModuleName,toFilePath) #endif +import Bag+import Lexer as L+import Parser+import SrcLoc+import Packages++import Language.Haskell.GhcMod.Types (Expression(..))+import Prelude+ ---------------------------------------------------------------- ---------------------------------------------------------------- --@@ -173,7 +186,11 @@ ----------------------------------------------------------------  fOptions :: [String]-#if __GLASGOW_HASKELL__ >= 704+#if __GLASGOW_HASKELL__ >= 710+fOptions = [option | (FlagSpec option _ _ _) <- fFlags]+        ++ [option | (FlagSpec option _ _ _) <- fWarningFlags]+        ++ [option | (FlagSpec option _ _ _) <- fLangFlags]+#elif __GLASGOW_HASKELL__ >= 704 fOptions = [option | (option,_,_) <- fFlags]         ++ [option | (option,_,_) <- fWarningFlags]         ++ [option | (option,_,_) <- fLangFlags]@@ -187,9 +204,11 @@ ----------------------------------------------------------------  fileModSummary :: GhcMonad m => FilePath -> m ModSummary-fileModSummary file = do+fileModSummary file' = do     mss <- getModuleGraph-    let [ms] = filter (\m -> ml_hs_file (ms_location m) == Just file) mss+    file <- liftIO $ canonicalizePath file'+    [ms] <- liftIO $ flip filterM mss $ \m ->+        (Just file==) <$> canonicalizePath `traverse` ml_hs_file (ms_location m)     return ms  withContext :: GhcMonad m => m a -> m a@@ -202,26 +221,31 @@         action     topImports = do         mss <- getModuleGraph-        ms <- map modName <$> filterM isTop mss+        mns <- map modName <$> filterM isTop mss+        let ii = map IIModule mns #if __GLASGOW_HASKELL__ >= 704-        return ms+        return ii #else-        return (ms,[])+        return (ii,[]) #endif     isTop mos = lookupMod mos ||> returnFalse     lookupMod mos = lookupModule (ms_mod_name mos) Nothing >> return True     returnFalse = return False #if __GLASGOW_HASKELL__ >= 706-    modName = IIModule . moduleName . ms_mod+    modName = moduleName . ms_mod     setCtx = setContext #elif __GLASGOW_HASKELL__ >= 704-    modName = IIModule . ms_mod+    modName = ms_mod     setCtx = setContext #else     modName = ms_mod     setCtx = uncurry setContext #endif +-- | Try the left action, if an IOException occurs try the right action.+(||>) :: ExceptionMonad m => m a -> m a -> m a+x ||> y = x `gcatch` (\(_ :: IOException) -> y)+ showSeverityCaption :: Severity -> String #if __GLASGOW_HASKELL__ >= 706 showSeverityCaption SevWarning = "Warning: "@@ -249,12 +273,6 @@ setHideAllPackages df = dopt_set df Opt_HideAllPackages #endif -addPackageFlags :: [Package] -> DynFlags -> DynFlags-addPackageFlags pkgs df =-    df { packageFlags = packageFlags df ++ expose `map` pkgs }-  where-    expose pkg = ExposePackageId $ showPkgId pkg- ----------------------------------------------------------------  setDumpSplices :: DynFlags -> DynFlags@@ -310,8 +328,8 @@   where     implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] -infoThing :: GhcMonad m => String -> m SDoc-infoThing str = do+infoThing :: GhcMonad m => Expression -> m SDoc+infoThing (Expression str) = do     names <- parseName str #if __GLASGOW_HASKELL__ >= 708     mb_stuffs <- mapM (getInfo False) names@@ -413,29 +431,6 @@ ---------------------------------------------------------------- ---------------------------------------------------------------- -benchmarkBuildInfo :: P.PackageDescription -> [P.BuildInfo]-#if __GLASGOW_HASKELL__ >= 704-benchmarkBuildInfo pd = map P.benchmarkBuildInfo $ P.benchmarks pd-#else-benchmarkBuildInfo pd = []-#endif--benchmarkTargets :: P.PackageDescription -> [String]-#if __GLASGOW_HASKELL__ >= 704-benchmarkTargets pd = map toModuleString $ concatMap P.benchmarkModules $ P.benchmarks pd-#else-benchmarkTargets = []-#endif--toModuleString :: M.ModuleName -> String-toModuleString mn = fromFilePath $ M.toFilePath mn-  where-    fromFilePath :: FilePath -> String-    fromFilePath fp = map (\c -> if c=='/' then '.' else c) fp------------------------------------------------------------------------------------------------------------------------------------ #if __GLASGOW_HASKELL__ >= 708 type GLMatch = LMatch RdrName (LHsExpr RdrName) type GLMatchI = LMatch Id (LHsExpr Id)@@ -445,8 +440,13 @@ #endif  getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan)-#if __GLASGOW_HASKELL__ >= 708+#if __GLASGOW_HASKELL__ >= 710 -- Instance declarations of sort 'instance F (G a)'+getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsForAllTy _ _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _))))}))] = Just (className, loc)+-- Instance declarations of sort 'instance F G' (no variables)+getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsAppTy (L _ (HsTyVar className)) _))}))] = Just (className, loc)+#elif __GLASGOW_HASKELL__ >= 708+-- Instance declarations of sort 'instance F (G a)' getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _))))}))] = Just (className, loc) -- Instance declarations of sort 'instance F G' (no variables) getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsAppTy (L _ (HsTyVar className)) _))}))] = Just (className, loc)@@ -465,11 +465,73 @@ #endif  --------------------------------------------------------------------------------------------------------------------------------- -setFlags :: DynFlags -> DynFlags-#if __GLASGOW_HASKELL__ >= 708-setFlags df = df `gopt_unset` Opt_SpecConstr -- consume memory if -O2+#if __GLASGOW_HASKELL__ < 710+-- Copied from ghc/InteractiveUI.hs+allExposedPackageConfigs :: DynFlags -> [PackageConfig]+allExposedPackageConfigs df = filter exposed $ eltsUFM $ pkgIdMap $ pkgState df++allExposedModules :: DynFlags -> [ModuleName]+allExposedModules df = concat $ map exposedModules $ allExposedPackageConfigs df++listVisibleModuleNames :: DynFlags -> [ModuleName]+listVisibleModuleNames = allExposedModules+#endif++lookupModulePackageInAllPackages ::+    DynFlags -> ModuleName -> [String]+lookupModulePackageInAllPackages df mn =+#if __GLASGOW_HASKELL__ >= 710+    unpackSPId . sourcePackageId . snd <$> lookupModuleInAllPackages df mn+ where+   unpackSPId (SourcePackageId fs) = unpackFS fs #else-setFlags = id+    unpackPId . sourcePackageId . fst <$> lookupModuleInAllPackages df mn+ where+   unpackPId pid = packageIdString $ mkPackageId pid+--       n ++ "-" ++ showVersion v #endif++listVisibleModules :: DynFlags -> [GHC.Module]+listVisibleModules df = let+#if __GLASGOW_HASKELL__ >= 710+    modNames = listVisibleModuleNames df+    mods = [ m | mn <- modNames, (m, _) <- lookupModuleInAllPackages df mn ]+#else+    pkgCfgs = allExposedPackageConfigs df+    mods = [ mkModule pid modname | p <- pkgCfgs+           , let pid = packageConfigId p+           , modname <- exposedModules p ]+#endif+    in mods++isSynTyCon :: TyCon -> Bool+#if __GLASGOW_HASKELL__ >= 710+isSynTyCon = GHC.isTypeSynonymTyCon+#else+isSynTyCon = GHC.isSynTyCon+#endif+++parseModuleHeader+    :: String         -- ^ Haskell module source text (full Unicode is supported)+    -> DynFlags+    -> FilePath       -- ^ the filename (for source locations)+    -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName))+parseModuleHeader str dflags filename =+   let+       loc  = mkRealSrcLoc (mkFastString filename) 1 1+       buf  = stringToStringBuffer str+   in+   case L.unP Parser.parseHeader (mkPState dflags buf loc) of++     PFailed sp err   ->+#if __GLASGOW_HASKELL__ >= 706+         Left (unitBag (mkPlainErrMsg dflags sp err))+#else+         Left (unitBag (mkPlainErrMsg sp err))+#endif++     POk pst rdr_module ->+         let (warns,_) = getMessages pst in+         Right (warns, rdr_module)

@@ -4,55 +4,29 @@   , ghcPkgDbStackOpts   , ghcDbStackOpts   , ghcDbOpt-  , fromInstalledPackageId-  , fromInstalledPackageId'   , getPackageDbStack   , getPackageCachePaths   ) where  import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt)-import Control.Applicative ((<$>))-import Data.List (intercalate)+import Control.Applicative import Data.List.Split (splitOn) import Data.Maybe-import Distribution.Package (InstalledPackageId(..)) import Exception (handleIO)-import Language.Haskell.GhcMod.PathsAndFiles-import Language.Haskell.GhcMod.Types import System.Directory (doesDirectoryExist, getAppUserDataDirectory) import System.FilePath ((</>))+import Prelude +import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.Monad.Types+import Language.Haskell.GhcMod.CabalHelper+import Language.Haskell.GhcMod.PathsAndFiles+ ghcVersion :: Int ghcVersion = read cProjectVersionInt -getPackageDbStack :: FilePath -- ^ Project Directory (where the-                                 -- cabal.sandbox.config file would be if it-                                 -- exists)-                  -> IO [GhcPkgDb]-getPackageDbStack cdir = do-    mSDir <- getSandboxDb cdir-    return $ [GlobalDb] ++ case mSDir of-                             Nothing -> [UserDb]-                             Just db -> [PackageDb db]- ---------------------------------------------------------------- -fromInstalledPackageId' :: InstalledPackageId -> Maybe Package-fromInstalledPackageId' pid = let-    InstalledPackageId pkg = pid-    in case reverse $ splitOn "-" pkg of-      i:v:rest -> Just (intercalate "-" (reverse rest), v, i)-      _ -> Nothing--fromInstalledPackageId :: InstalledPackageId -> Package-fromInstalledPackageId pid =-    case fromInstalledPackageId' pid of-      Just p -> p-      Nothing -> error $-        "fromInstalledPackageId: `"++show pid++"' is not a valid package-id"------------------------------------------------------------------- -- | Get options needed to add a list of package dbs to ghc-pkg's db stack ghcPkgDbStackOpts :: [GhcPkgDb] -- ^ Package db stack                   -> [String]@@ -85,11 +59,24 @@  ---------------------------------------------------------------- --getPackageCachePaths :: FilePath -> Cradle -> IO [FilePath]-getPackageCachePaths sysPkgCfg crdl =-    catMaybes <$> resolvePackageConfig sysPkgCfg `mapM` cradlePkgDbStack crdl+getPackageDbStack :: IOish m => GhcModT m [GhcPkgDb]+getPackageDbStack = do+  crdl <- cradle+  mCusPkgStack <- getCustomPkgDbStack+  stack <- case cradleProjectType crdl of+    PlainProject ->+        return [GlobalDb, UserDb]+    SandboxProject -> do+        Just db <- liftIO $ getSandboxDb $ cradleRootDir crdl+        return $ [GlobalDb, db]+    CabalProject ->+        getCabalPackageDbStack+  return $ fromMaybe stack mCusPkgStack +getPackageCachePaths :: IOish m => FilePath -> GhcModT m [FilePath]+getPackageCachePaths sysPkgCfg = do+  pkgDbStack <- getPackageDbStack+  catMaybes <$> (liftIO . resolvePackageConfig sysPkgCfg) `mapM` pkgDbStack  -- TODO: use PkgConfRef --- Copied from ghc module `Packages' unfortunately it's not exported :/

@@ -0,0 +1,263 @@+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE ScopedTypeVariables, RecordWildCards #-}+module Language.Haskell.GhcMod.HomeModuleGraph (+   GmModuleGraph(..)+ , ModulePath(..)+ , mkFileMap+ , mkModuleMap+ , mkMainModulePath+ , findModulePath+ , findModulePathSet+ , fileModuleName+ , canonicalizeModulePath+ , homeModuleGraph+ , updateHomeModuleGraph+ , canonicalizeModuleGraph+ , reachable+ , moduleGraphToDot+ ) where++import DriverPipeline+import DynFlags+import ErrUtils+import Exception+import Finder+import GHC+import HscTypes++import Control.Arrow ((&&&))+import Control.Applicative+import Control.Monad+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)+import Control.Monad.State.Strict (execStateT)+import Control.Monad.State.Class+import Data.Maybe+import Data.Monoid as Monoid+import Data.Map  (Map)+import qualified Data.Map  as Map+import Data.Set (Set)+import qualified Data.Set as Set+import System.FilePath+import System.Directory+import Prelude++import Language.Haskell.GhcMod.Logging+import Language.Haskell.GhcMod.Logger+import Language.Haskell.GhcMod.Monad.Types+import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.Gap (parseModuleHeader)++-- | Turn module graph into a graphviz dot file+--+-- @dot -Tpng -o modules.png modules.dot@+moduleGraphToDot :: GmModuleGraph -> String+moduleGraphToDot GmModuleGraph { gmgGraph } =+    "digraph {\n" ++ concatMap edges (Map.toList graph) ++ "}\n"+ where+   graph = Map.map (Set.mapMonotonic mpPath)+         $ Map.mapKeysMonotonic mpPath gmgGraph+   edges :: (FilePath, (Set FilePath)) -> String+   edges (f, sf) =+       concatMap (\f' -> "    \""++ f ++"\" -> \""++ f' ++"\"\n") (Set.toList sf)++data S = S {+      sErrors   :: [(ModulePath, ErrorMessages)],+      sWarnings :: [(ModulePath, WarningMessages)],+      sGraph    :: GmModuleGraph+}++defaultS :: S+defaultS = S [] [] mempty++putErr :: MonadState S m+       => (ModulePath, ErrorMessages) -> m ()+putErr e = do+  s <- get+  put s { sErrors = e:sErrors s}++putWarn :: MonadState S m+       => (ModulePath, ErrorMessages) -> m ()+putWarn w = do+  s <- get+  put s { sWarnings = w:sWarnings s}++gmgLookupMP :: MonadState S m => ModulePath -> m (Maybe (Set ModulePath))+gmgLookupMP k = (Map.lookup k . gmgGraph . sGraph) `liftM` get++graphUnion :: MonadState S m => GmModuleGraph -> m ()+graphUnion gmg = do+  s <- get+  put s { sGraph = sGraph s `mappend` gmg }++reachable :: Set ModulePath -> GmModuleGraph -> Set ModulePath+reachable smp0 GmModuleGraph {..} = go smp0+ where+   go smp = let+       δsmp = Set.unions $+                collapseMaybeSet . flip Map.lookup gmgGraph <$> Set.toList smp+       smp' = smp `Set.union` δsmp+    in if smp == smp' then smp' else go smp'++pruneUnreachable :: Set ModulePath -> GmModuleGraph -> GmModuleGraph+pruneUnreachable smp0 gmg@GmModuleGraph {..} = let+    r = reachable smp0 gmg+  in+    GmModuleGraph {+      gmgGraph = Map.filterWithKey (\k _ -> k `Set.member` r) gmgGraph+    }++collapseMaybeSet :: Maybe (Set a) -> Set a+collapseMaybeSet = maybe Set.empty id++homeModuleGraph :: (IOish m, GmLog m, GmEnv m)+    => HscEnv -> Set ModulePath -> m GmModuleGraph+homeModuleGraph env smp = updateHomeModuleGraph env mempty smp smp++mkMainModulePath :: FilePath -> ModulePath+mkMainModulePath = ModulePath (mkModuleName "Main")++findModulePath :: HscEnv -> ModuleName -> IO (Maybe ModulePath)+findModulePath env mn = do+    fmap (ModulePath mn) <$> find env mn++findModulePathSet :: HscEnv -> [ModuleName] -> IO (Set ModulePath)+findModulePathSet env mns = do+    Set.fromList . catMaybes <$> findModulePath env `mapM` mns++find :: MonadIO m => HscEnv -> ModuleName -> m (Maybe FilePath)+find env mn = liftIO $ do+  res <- findHomeModule env mn+  case res of+   -- TODO: handle SOURCE imports (hs-boot stuff): addBootSuffixLocn loc+    Found loc@ModLocation { ml_hs_file = Just _ } _mod ->+        return $ normalise <$> ml_hs_file loc+    _ -> return Nothing+++canonicalizeModulePath :: ModulePath -> IO ModulePath+canonicalizeModulePath (ModulePath mn fp) = ModulePath mn <$> canonicalizePath fp++canonicalizeModuleGraph :: MonadIO m => GmModuleGraph -> m GmModuleGraph+canonicalizeModuleGraph GmModuleGraph {..} = liftIO $ do+    GmModuleGraph . Map.fromList <$> mapM fmg (Map.toList gmgGraph)+ where+   fmg (mp, smp) = liftM2 (,) (canonicalizeModulePath mp) (Set.fromList <$> mapM canonicalizeModulePath (Set.toList smp))+++updateHomeModuleGraph :: (IOish m, GmLog m, GmEnv m)+                      => HscEnv+                      -> GmModuleGraph+                      -> Set ModulePath -- ^ Initial set of modules+                      -> Set ModulePath -- ^ Updated set of modules+                      -> m GmModuleGraph+updateHomeModuleGraph env GmModuleGraph {..} smp sump = do+    -- TODO: It would be good if we could retain information about modules that+    -- stop to compile after we've already successfully parsed them at some+    -- point. Figure out a way to delete the modules about to be updated only+    -- after we're sure they won't fail to parse .. or something. Should probably+    -- push this whole prune logic deep into updateHomeModuleGraph'+   (pruneUnreachable smp . sGraph) `liftM` runS (updateHomeModuleGraph' env sump)+ where+   runS = flip execStateT defaultS { sGraph = graph' }+   graph' = GmModuleGraph {+       gmgGraph = Set.foldr Map.delete gmgGraph sump+    }++mkFileMap :: Set ModulePath -> Map FilePath ModulePath+mkFileMap smp = Map.fromList $ map (mpPath &&& id) $ Set.toList smp++mkModuleMap :: Set ModulePath -> Map ModuleName ModulePath+mkModuleMap smp = Map.fromList $ map (mpModule &&& id) $ Set.toList smp++updateHomeModuleGraph'+    :: forall m. (MonadState S m, IOish m, GmLog m, GmEnv m)+    => HscEnv+    -> Set ModulePath     -- ^ Initial set of modules+    -> m ()+updateHomeModuleGraph' env smp0 = do+    go `mapM_` Set.toList smp0+ where+   go :: ModulePath -> m ()+   go mp = do+     msmp <- gmgLookupMP mp+     case msmp of+       Just _ -> return ()+       Nothing -> do+           smp <- collapseMaybeSet `liftM` step mp++           graphUnion GmModuleGraph {+               gmgGraph = Map.singleton mp smp+            }++           mapM_ go (Set.toList smp)++   step :: ModulePath -> m (Maybe (Set ModulePath))+   step mp = runMaybeT $ do+       (dflags, ppsrc_fn) <- MaybeT preprocess'+       src <- liftIO $ readFile ppsrc_fn+       imports mp src dflags+    where+      preprocess' :: m (Maybe (DynFlags, FilePath))+      preprocess' = do+        let fn = mpPath mp+        ep <- preprocessFile env fn+        case ep of+          Right (_, x) -> return $ Just x+          Left errs -> do+            -- TODO: Remember these and present them as proper errors if this is+            -- the file the user is looking at.+            gmLog GmWarning ("preprocess " ++ show fn) $ Monoid.mempty $+$ (vcat $ map text errs)+            return Nothing++   imports :: ModulePath -> String -> DynFlags -> MaybeT m (Set ModulePath)+   imports mp@ModulePath {..} src dflags =+       case parseModuleHeader src dflags mpPath of+         Left err -> do+           putErr (mp, err)+           mzero++         Right (ws, lmdl) -> do+           putWarn (mp, ws)+           let HsModule {..} = unLoc lmdl+               mns = map (unLoc . ideclName)+                   $ filter (isNothing . ideclPkgQual)+                   $ map unLoc hsmodImports+           liftIO $ Set.fromList . catMaybes <$> mapM (findModulePath env) mns++preprocessFile :: MonadIO m =>+  HscEnv -> FilePath -> m (Either [String] ([String], (DynFlags, FilePath)))+preprocessFile env file =+  liftIO $ withLogger' env $ \setDf -> do+    let env' = env { hsc_dflags = setDf (hsc_dflags env) }+    preprocess env' (file, Nothing)++fileModuleName ::+  HscEnv -> FilePath -> IO (Either [String] (Maybe ModuleName))+fileModuleName env fn = handle (\(_ :: SomeException) -> return $ Right Nothing) $ do+    ep <- preprocessFile env fn+    case ep of+      Left errs -> do+        return $ Left errs+      Right (_warns, (dflags, procdFile)) -> do+        src <- readFile procdFile+        case parseModuleHeader src dflags procdFile of+          Left errs -> do+            return $ Left $ errBagToStrList env errs+          Right (_, lmdl) -> do+            let HsModule {..} = unLoc lmdl+            return $ Right $ unLoc <$> hsmodName

@@ -3,20 +3,25 @@   , types   ) where -import Control.Applicative ((<$>))+import Control.Applicative import Data.Function (on) import Data.List (sortBy) import Data.Maybe (catMaybes)+import System.FilePath import Exception (ghandle, SomeException(..)) import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan, Type)+import Prelude import qualified GHC as G-import Language.Haskell.GhcMod.Doc (showPage)-import Language.Haskell.GhcMod.Gap (HasType(..)) import qualified Language.Haskell.GhcMod.Gap as Gap++import Language.Haskell.GhcMod.Convert+import Language.Haskell.GhcMod.Doc+import Language.Haskell.GhcMod.DynFlags+import Language.Haskell.GhcMod.Gap+import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.SrcUtils import Language.Haskell.GhcMod.Types-import Language.Haskell.GhcMod.Convert  ---------------------------------------------------------------- @@ -25,15 +30,23 @@      => FilePath     -- ^ A target file.      -> Expression   -- ^ A Haskell expression.      -> GhcModT m String-info file expr = do-    opt <- options-    convert opt <$> ghandle handler body+info file expr =+  ghandle handler $+    runGmlT' [Left file] deferErrors $+      withContext $+        convert <$> options <*> body   where-    body = inModuleContext file $ \dflag style -> do-        sdoc <- Gap.infoThing expr-        return $ showPage dflag style sdoc-    handler (SomeException _) = return "Cannot show info"+    handler (SomeException ex) = do+      gmLog GmException "info" $ text "" $$ nest 4 (showDoc ex)+      convert' "Cannot show info" +    body :: GhcMonad m => m String+    body = do+      sdoc  <- Gap.infoThing expr+      st    <- getStyle+      dflag <- G.getSessionDynFlags+      return $ showPage dflag st sdoc+ ----------------------------------------------------------------  -- | Obtaining type of a target expression. (GHCi's type:)@@ -42,24 +55,29 @@       -> Int          -- ^ Line number.       -> Int          -- ^ Column number.       -> GhcModT m String-types file lineNo colNo = do-    opt <- options-    convert opt <$> ghandle handler body-  where-    body = inModuleContext file $ \dflag style -> do-        modSum <- Gap.fileModSummary file+types file lineNo colNo =+  ghandle handler $+    runGmlT' [Left file] deferErrors $+      withContext $ do+        crdl         <- cradle+        modSum       <- Gap.fileModSummary (cradleCurrentDir crdl </> file)         srcSpanTypes <- getSrcSpanType modSum lineNo colNo-        return $ map (toTup dflag style) $ sortBy (cmp `on` fst) srcSpanTypes-    handler (SomeException _) = return []+        dflag        <- G.getSessionDynFlags+        st           <- getStyle+        convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes+ where+   handler (SomeException ex) = do+     gmLog GmException "types" $ showDoc ex+     return []  getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)] getSrcSpanType modSum lineNo colNo = do-    p <- G.parseModule modSum-    tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p-    let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id]-        es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id]-        ps = listifySpans tcs (lineNo, colNo) :: [LPat Id]-    bts <- mapM (getType tcm) bs-    ets <- mapM (getType tcm) es-    pts <- mapM (getType tcm) ps-    return $ catMaybes $ concat [ets, bts, pts]+  p <- G.parseModule modSum+  tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p+  let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id]+      es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id]+      ps = listifySpans tcs (lineNo, colNo) :: [LPat Id]+  bts <- mapM (getType tcm) bs+  ets <- mapM (getType tcm) es+  pts <- mapM (getType tcm) ps+  return $ catMaybes $ concat [ets, bts, pts]

@@ -8,35 +8,33 @@   , PackageVersion   , PackageId   , IncludeDir-  , CompilerOptions(..)-  -- * Cabal API-  , parseCabalFile-  , getCompilerOptions-  , cabalAllBuildInfo-  , cabalDependPackages-  , cabalSourceDirs-  , cabalAllTargets+  , GmlT(..)+  , MonadIO(..)+  , GmEnv(..)   -- * Various Paths   , ghcLibDir   , ghcModExecutable-  -- * IO-  , getDynamicFlags-  -- * Targets-  , setTargetFiles   -- * Logging   , withLogger   , setNoWarningFlags   , setAllWarningFlags   -- * Environment, state and logging   , GhcModEnv(..)-  , newGhcModEnv   , GhcModState-  , defaultState   , CompilerMode(..)   , GhcModLog+  , GmLog(..)+  , GmLogLevel(..)+  , gmSetLogLevel   -- * Monad utilities   , runGhcModT'   , hoistGhcModT+  , runGmlT+  , runGmlT'+  , gmlGetSession+  , gmlSetSession+  , loadTargets+  , cabalResolvedComponents   -- ** Accessing 'GhcModEnv' and 'GhcModState'   , options   , cradle@@ -45,28 +43,33 @@   , withOptions   -- * 'GhcModError'   , gmeDoc-  -- * 'GhcMonad' Choice-  , (||>)-  , goNext-  , runAnyOne   -- * World   , World   , getCurrentWorld   , didWorldChange+  -- * Cabal Helper+  , ModulePath(..)+  , GmComponent(..)+  , GmComponentType(..)+  , GmModuleGraph(..)+  , prepareCabalHelper+  -- * Misc stuff+  , GHandler(..)+  , gcatches   ) where  import GHC.Paths (libdir) -import Language.Haskell.GhcMod.CabalApi+import Language.Haskell.GhcMod.Target import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.Error-import Language.Haskell.GhcMod.GHCChoice import Language.Haskell.GhcMod.Logger+import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.Target import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.World+import Language.Haskell.GhcMod.CabalHelper  -- | Obtaining the directory for ghc system libraries. ghcLibDir :: FilePath

@@ -1,31 +1,33 @@-{-# LANGUAGE CPP #-}- module Language.Haskell.GhcMod.Logger (     withLogger-  , withLoggerTwice+  , withLogger'   , checkErrorPrefix+  , errsToStr+  , errBagToStrList   ) where -import Bag (Bag, bagToList, emptyBag, consBag, filterBag, unionBags)-import Control.Applicative ((<$>))+import Control.Arrow+import Control.Applicative+import Data.List (isPrefixOf)+import Data.Maybe (fromMaybe) import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)-import Data.List (isPrefixOf, find, nub, isInfixOf)-import Data.Maybe (fromMaybe, isJust)-import ErrUtils (ErrMsg, WarnMsg, errMsgShortDoc, errMsgExtraInfo, mkWarnMsg)-import Exception (ghandle)+import System.FilePath (normalise)+import Text.PrettyPrint++import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo) import GHC (DynFlags, SrcSpan, Severity(SevError))+import HscTypes+import Outputable import qualified GHC as G-import HscTypes (SourceError, srcErrorMessages)-import Language.Haskell.GhcMod.Doc (showPage, getStyle)-import Language.Haskell.GhcMod.DynFlags (withDynFlags, withCmdFlags)-import qualified Language.Haskell.GhcMod.Gap as Gap-import Language.Haskell.GhcMod.Convert (convert')-import Language.Haskell.GhcMod.Monad-import Language.Haskell.GhcMod.Types-import Outputable (PprStyle, SDoc, qualName, qualModule, mkErrStyle, neverQualify)-import System.FilePath (normalise)+import Bag -----------------------------------------------------------------+import Language.Haskell.GhcMod.Convert+import Language.Haskell.GhcMod.Doc (showPage)+import Language.Haskell.GhcMod.DynFlags (withDynFlags)+import Language.Haskell.GhcMod.Monad.Types+import Language.Haskell.GhcMod.Error+import qualified Language.Haskell.GhcMod.Gap as Gap+import Prelude  type Builder = [String] -> [String] @@ -39,178 +41,94 @@ newLogRef :: IO LogRef newLogRef = LogRef <$> newIORef emptyLog -readAndClearLogRef :: IOish m => LogRef -> GhcModT m String+readAndClearLogRef :: LogRef -> IO [String] readAndClearLogRef (LogRef ref) = do-    Log _ b <- liftIO $ readIORef ref-    liftIO $ writeIORef ref emptyLog-    convert' (b [])+    Log _ b <- readIORef ref+    writeIORef ref emptyLog+    return $ b []  appendLogRef :: DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()-appendLogRef df (LogRef ref) _ sev src style msg = modifyIORef ref update+appendLogRef df (LogRef ref) _ sev src st msg = modifyIORef ref update   where-    l = ppMsg src sev df style msg+    l = ppMsg src sev df st msg     update lg@(Log ls b)       | l `elem` ls = lg       | otherwise   = Log (l:ls) (b . (l:))  ---------------------------------------------------------------- -data LogBag = LogBag (Bag WarnMsg)-newtype LogBagRef = LogBagRef (IORef LogBag)--emptyLogBag :: LogBag-emptyLogBag = LogBag emptyBag--newLogBagRef :: IO LogBagRef-newLogBagRef = LogBagRef <$> newIORef emptyLogBag--readAndClearLogBagRef :: IOish m => LogBagRef -> GhcModT m (Bag WarnMsg)-readAndClearLogBagRef (LogBagRef ref) = do-    LogBag b <- liftIO $ readIORef ref-    liftIO $ writeIORef ref emptyLogBag-    return b--appendLogBagRef :: DynFlags -> LogBagRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()-appendLogBagRef df (LogBagRef ref) _ _ src style msg = modifyIORef ref update-  where-    qstyle = (qualName style, qualModule style)-#if __GLASGOW_HASKELL__ >= 706-    warnMsg = mkWarnMsg df src qstyle msg-#else-    warnMsg = mkWarnMsg src qstyle msg-#endif-    warnBag = consBag warnMsg emptyBag-    update (LogBag b) = let (b1,b2) = mergeErrors df style b warnBag-                         in LogBag $ b1 `unionBags` b2------------------------------------------------------------------- -- | Set the session flag (e.g. "-Wall" or "-w:") then --   executes a body. Logged messages are returned as 'String'. --   Right is success and Left is failure.-withLogger :: IOish m+withLogger :: (GmGhc m, GmEnv m)            => (DynFlags -> DynFlags)-           -> GhcModT m ()-           -> GhcModT m (Either String String)-withLogger setDF body = ghandle sourceError $ do-    logref <- liftIO newLogRef-    wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options-    withDynFlags (setLogger logref . setDF) $-        withCmdFlags wflags $ do-            body-            Right <$> readAndClearLogRef logref-  where-    setLogger logref df = Gap.setLogAction df $ appendLogRef df logref--withLoggerTwice :: IOish m-                => (DynFlags -> DynFlags)-                -> GhcModT m ()-                -> (DynFlags -> DynFlags)-                -> GhcModT m ()-                -> GhcModT m (Either String String)-withLoggerTwice setDF1 body1 setDF2 body2 = do-  err1 <- ghandle sourceErrorBag $ do-    logref <- liftIO newLogBagRef-    wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options-    withDynFlags (setLogger logref . setDF1) $-        withCmdFlags wflags $ do-            body1-            Right <$> readAndClearLogBagRef logref-  err2 <- ghandle sourceErrorBag $ do-    logref <- liftIO newLogBagRef-    wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options-    withDynFlags (setLogger logref . setDF2) $-        withCmdFlags wflags $ do-            body2-            Right <$> readAndClearLogBagRef logref-  -- Merge errors and warnings-  dflags <- G.getSessionDynFlags-  style <- getStyle-  case (err1, err2) of-    (Right b1, Right b2) -> do let (warn1,_) = mergeErrors dflags style b1 b2-                               errAndWarnBagToStr Right emptyBag (warn1 `unionBags` b2)-    (Left  b1, Right b2) -> do let (err,warn) = mergeErrors dflags style b1 b2-                               errAndWarnBagToStr Right err warn-    (Right b1, Left  b2) -> do let (err,warn) = mergeErrors dflags style b2 b1-                               errAndWarnBagToStr Right err warn-    (Left  b1, Left  b2) -> do let (err1',err2') = mergeErrors dflags style b1 b2-                               errAndWarnBagToStr Right (err1' `unionBags` err2') emptyBag-  where-    setLogger logref df = Gap.setLogAction df $ appendLogBagRef df logref+           -> m a+           -> m (Either String (String, a))+withLogger f action = do+  env <- G.getSession+  opts <- options+  let conv = convert opts+  eres <- withLogger' env $ \setDf ->+      withDynFlags (f . setDf) action+  return $ either (Left . conv) (Right . first conv) eres -----------------------------------------------------------------+withLogger' :: IOish m+    => HscEnv -> ((DynFlags -> DynFlags) -> m a) -> m (Either [String] ([String], a))+withLogger' env action = do+    logref <- liftIO $ newLogRef --- | Converting 'SourceError' to 'String'.-sourceError :: IOish m => SourceError -> GhcModT m (Either String String)-sourceError err = errBagToStr (srcErrorMessages err)+    let dflags = hsc_dflags env+        pu = icPrintUnqual dflags (hsc_IC env)+        st = mkUserStyle pu AllTheWay -errBagToStr :: IOish m => Bag ErrMsg -> GhcModT m (Either String String)-errBagToStr = errBagToStr' Left+        fn df  = setLogger logref df -errBagToStr' :: IOish m => (String -> a) -> Bag ErrMsg -> GhcModT m a-errBagToStr' f err = do-    dflags <- G.getSessionDynFlags-    style <- getStyle-    ret <- convert' (errBagToStrList dflags style err)-    return $ f ret+    a <- gcatches (Right <$> action fn) (handlers dflags st)+    ls <- liftIO $ readAndClearLogRef logref -errAndWarnBagToStr :: IOish m => (String -> a) -> Bag ErrMsg -> Bag WarnMsg -> GhcModT m a-errAndWarnBagToStr f err warn = do-    dflags <- G.getSessionDynFlags-    -- style <- toGhcModT getStyle-#if __GLASGOW_HASKELL__ >= 706-    let style = mkErrStyle dflags neverQualify-#else-    let style = mkErrStyle neverQualify-#endif-    ret <- convert' $ nub (errBagToStrList dflags style err ++ warnBagToStrList dflags style warn)-    return $ f ret+    return $ ((,) ls <$> a) -errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String]-errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList+  where+    setLogger logref df = Gap.setLogAction df $ appendLogRef df logref+    handlers df st = [+        GHandler $ \ex -> return $ Left $ sourceError df st ex,+        GHandler $ \ex -> return $ Left [render $ ghcExceptionDoc ex]+     ] -warnBagToStrList :: DynFlags -> PprStyle -> Bag WarnMsg -> [String]-warnBagToStrList dflag style = map (ppWarnMsg dflag style) . reverse . bagToList+errBagToStrList :: HscEnv -> Bag ErrMsg -> [String]+errBagToStrList env errs = let+    dflags = hsc_dflags env+    pu = icPrintUnqual dflags (hsc_IC env)+    st = mkUserStyle pu AllTheWay+ in errsToStr dflags st $ bagToList errs -sourceErrorBag :: IOish m => SourceError -> GhcModT m (Either (Bag ErrMsg) (Bag WarnMsg))-sourceErrorBag err = return $ Left (srcErrorMessages err)+---------------------------------------------------------------- -mergeErrors :: DynFlags -> PprStyle -> Bag ErrMsg -> Bag ErrMsg -> (Bag ErrMsg, Bag ErrMsg)-mergeErrors dflag style b1 b2 =-  let b1Msgs = map (\err1 -> let m = ppWarnMsg dflag style err1 in (m, head $ lines m))-                   (bagToList b1)-      mustBeB2 = \err2 -> let msg2  = ppWarnMsg dflag style err2-                              line2 = head $ lines msg2-                           in not . isJust $ find (\(msg1, line1) -> msg1 == msg2 || (line1 == line2 && isHoleMsg line1)) b1Msgs-   in (b1, filterBag mustBeB2 b2)+-- | Converting 'SourceError' to 'String'.+sourceError :: DynFlags -> PprStyle -> SourceError -> [String]+sourceError df st src_err = errsToStr df st $ reverse $ bagToList $ srcErrorMessages src_err -isHoleMsg :: String -> Bool-isHoleMsg = isInfixOf "Found hole"+errsToStr :: DynFlags -> PprStyle -> [ErrMsg] -> [String]+errsToStr df st = map (ppErrMsg df st)  ----------------------------------------------------------------  ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String-ppErrMsg dflag style err = ppMsg spn SevError dflag style msg ++ (if null ext then "" else "\n" ++ ext)-   where-     spn = Gap.errorMsgSpan err-     msg = errMsgShortDoc err-     ext = showPage dflag style (errMsgExtraInfo err)--ppWarnMsg :: DynFlags -> PprStyle -> ErrMsg -> String-ppWarnMsg dflag style err = ppMsg spn G.SevWarning dflag style msg ++ (if null ext then "" else "\n" ++ ext)+ppErrMsg dflag st err =+    ppMsg spn SevError dflag st msg ++ (if null ext then "" else "\n" ++ ext)    where      spn = Gap.errorMsgSpan err      msg = errMsgShortDoc err-     ext = showPage dflag style (errMsgExtraInfo err)+     ext = showPage dflag st (errMsgExtraInfo err)  ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String-ppMsg spn sev dflag style msg = prefix ++ cts+ppMsg spn sev dflag st msg = prefix ++ cts   where-    cts  = showPage dflag style msg-    prefix = ppMsgPrefix spn sev dflag style cts+    cts  = showPage dflag st msg+    prefix = ppMsgPrefix spn sev dflag st cts  ppMsgPrefix :: SrcSpan -> Severity-> DynFlags -> PprStyle -> String -> String-ppMsgPrefix spn sev dflag _style cts =+ppMsgPrefix spn sev dflag _st cts =   let defaultPrefix         | Gap.isDumpSplices dflag = ""         | otherwise               = checkErrorPrefix

@@ -0,0 +1,102 @@+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Language.Haskell.GhcMod.Logging (+    module Language.Haskell.GhcMod.Logging+  , module Language.Haskell.GhcMod.Pretty+  , GmLogLevel(..)+  , module Text.PrettyPrint+  , module Data.Monoid+  ) where++import Control.Applicative hiding (empty)+import Control.Monad+import Control.Monad.Trans.Class+import Data.List+import Data.Char+import Data.Monoid+import Data.Maybe+import System.IO+import System.FilePath+import Text.PrettyPrint hiding (style, (<>))+import Prelude++import Language.Haskell.GhcMod.Monad.Types+import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.Pretty+import Language.Haskell.GhcMod.Output++gmSetLogLevel :: GmLog m => GmLogLevel -> m ()+gmSetLogLevel level =+    gmlJournal $ GhcModLog (Just level) (Last Nothing) []++gmSetDumpLevel :: GmLog m => Bool -> m ()+gmSetDumpLevel level =+    gmlJournal $ GhcModLog Nothing (Last (Just level)) []+++increaseLogLevel :: GmLogLevel -> GmLogLevel+increaseLogLevel l | l == maxBound = l+increaseLogLevel l = succ l++decreaseLogLevel :: GmLogLevel -> GmLogLevel+decreaseLogLevel l | l == minBound = l+decreaseLogLevel l = pred l++-- |+-- >>> Just GmDebug <= Nothing+-- False+-- >>> Just GmException <= Just GmDebug+-- True+-- >>> Just GmDebug <= Just GmException+-- False+gmLog :: (MonadIO m, GmLog m, GmEnv m) => GmLogLevel -> String -> Doc -> m ()+gmLog level loc' doc = do+  GhcModLog { gmLogLevel = Just level' } <- gmlHistory++  let loc | loc' == "" = empty+          | otherwise = text loc' <+>: empty+      msgDoc = gmLogLevelDoc level <+>: sep [loc, doc]+      msg = dropWhileEnd isSpace $ gmRenderDoc msgDoc++  when (level <= level') $ gmErrStrLn msg++  gmlJournal (GhcModLog Nothing (Last Nothing) [(level, loc', msgDoc)])++gmVomit :: (MonadIO m, GmLog m, GmEnv m) => String -> Doc -> String -> m ()+gmVomit filename doc content = do+  gmLog GmVomit "" $ doc <+>: text content++  GhcModLog { gmLogVomitDump = Last mdump }+      <- gmlHistory++  dir <- cradleTempDir `liftM` cradle+  when (fromMaybe False mdump) $+       liftIO $ writeFile (dir </> filename) content+++newtype LogDiscardT m a = LogDiscardT { runLogDiscard :: m a }+    deriving (Functor, Applicative, Monad)++instance MonadTrans LogDiscardT where+    lift = LogDiscardT++instance Monad m => GmLog (LogDiscardT m) where+    gmlJournal = const $ return ()+    gmlHistory = return mempty+    gmlClear = return ()

@@ -1,32 +1,26 @@ module Language.Haskell.GhcMod.Modules (modules) where -import Control.Applicative ((<$>))-import Control.Exception (SomeException(..))-import Data.List (nub, sort)-import qualified GHC as G+import Control.Arrow+import Data.List import Language.Haskell.GhcMod.Convert-import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types-import Packages (pkgIdMap, exposedModules, sourcePackageId, display)-import UniqFM (eltsUFM)+import Language.Haskell.GhcMod.Monad+import Language.Haskell.GhcMod.Gap ( listVisibleModuleNames+                                   , lookupModulePackageInAllPackages+                                   ) +import qualified GHC as G+ ----------------------------------------------------------------  -- | Listing installed modules.-modules :: IOish m => GhcModT m String+modules :: (IOish m, GmEnv m, GmState m, GmLog m) => m String modules = do-    opt <- options-    convert opt . arrange opt <$> (getModules `G.gcatch` handler)-  where-    getModules = getExposedModules <$> G.getSessionDynFlags-    getExposedModules = concatMap exposedModules'-                      . eltsUFM . pkgIdMap . G.pkgState-    exposedModules' p =-        map G.moduleNameString (exposedModules p)-    	`zip`-        repeat (display $ sourcePackageId p)-    arrange opt = nub . sort . map (dropPkgs opt)-    dropPkgs opt (name, pkg)-      | detailed opt = name ++ " " ++ pkg-      | otherwise = name-    handler (SomeException _) = return []+  Options { detailed } <- options+  df <- runGmPkgGhc G.getSessionDynFlags+  let mns = listVisibleModuleNames df+      pmnss = map (first moduleNameString) $ zip mns (modulePkg df `map` mns)+  convert' $ nub [ if detailed then pkg ++ " " ++ mn else mn+                 | (mn, pkgs) <- pmnss, pkg <- pkgs ]+ where+   modulePkg df = lookupModulePackageInAllPackages df

@@ -1,289 +1,100 @@-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-}-{-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>. +{-# LANGUAGE CPP #-} module Language.Haskell.GhcMod.Monad (-  -- * Monad Types-    GhcModT-  , IOish-  -- ** Environment, state and logging-  , GhcModEnv(..)-  , newGhcModEnv-  , GhcModState(..)-  , defaultState-  , CompilerMode(..)-  , GhcModLog-  , GhcModError(..)-  -- * Monad utilities-  , runGhcModT+    runGhcModT   , runGhcModT'+  , runGhcModT''   , hoistGhcModT-  -- ** Accessing 'GhcModEnv' and 'GhcModState'-  , gmsGet-  , gmsPut-  , options-  , cradle-  , getCompilerMode-  , setCompilerMode-  , withOptions-  , withTempSession-  , overrideGhcUserOptions-  -- ** Re-exporting convenient stuff-  , liftIO-  , module Control.Monad.Reader.Class-  , module Control.Monad.Journal.Class+  , runGmlT+  , runGmlT'+  , runGmlTWith+  , runGmPkgGhc+  , withGhcModEnv+  , withGhcModEnv'+  , module Language.Haskell.GhcMod.Monad.Types   ) where -#if __GLASGOW_HASKELL__ < 708--- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different--- classes before ghc 7.8-#define DIFFERENT_MONADIO 1---- RWST doen't have a MonadIO instance before ghc 7.8-#define MONADIO_INSTANCES 1-#endif-- import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.Monad.Types import Language.Haskell.GhcMod.Error+import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Cradle-import Language.Haskell.GhcMod.DynFlags-import Language.Haskell.GhcMod.GhcPkg-import Language.Haskell.GhcMod.CabalApi-import qualified Language.Haskell.GhcMod.Gap as Gap--import DynFlags-import GHC-import qualified GHC as G-import GHC.Paths (libdir)-import GhcMonad hiding (withTempSession)-#if __GLASGOW_HASKELL__ <= 702-import HscTypes-#endif---- MonadUtils of GHC 7.6 or earlier defines its own MonadIO.--- RWST does not automatically become an instance of MonadIO.--- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class.--- So, RWST automatically becomes an instance of MonadIO.-import MonadUtils--#if DIFFERENT_MONADIO-import Control.Monad.Trans.Class (lift)-import qualified Control.Monad.IO.Class-import Data.Monoid (Monoid)-#endif+import Language.Haskell.GhcMod.Target+import Language.Haskell.GhcMod.Output -import Control.Applicative (Alternative) import Control.Arrow (first)-import Control.Monad (MonadPlus, void)-#if !MIN_VERSION_monad_control(1,0,0)-import Control.Monad (liftM)-#endif-import Control.Monad.Base (MonadBase, liftBase)---- Monad transformer stuff-import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith,-  control, liftBaseOp, liftBaseOp_)--import Control.Monad.Trans.Class-import Control.Monad.Reader.Class-import Control.Monad.Writer.Class (MonadWriter)-import Control.Monad.State.Class (MonadState(..))--import Control.Monad.Error (ErrorT, runErrorT)-import Control.Monad.Reader (ReaderT, runReaderT)-import Control.Monad.State.Strict (StateT, runStateT)-import Control.Monad.Trans.Journal (JournalT, runJournalT)-#ifdef MONADIO_INSTANCES-import Control.Monad.Trans.Maybe (MaybeT)-import Control.Monad.Error (Error(..))-#endif-import Control.Monad.Journal.Class--import Data.Maybe (isJust)-import Data.IORef (IORef, readIORef, writeIORef, newIORef)-import System.Directory (getCurrentDirectory)--------------------------------------------------------------------data GhcModEnv = GhcModEnv {-      gmGhcSession :: !(IORef HscEnv)-    , gmOptions    :: Options-    , gmCradle     :: Cradle-    }--type GhcModLog = ()--data GhcModState = GhcModState {-      gmCompilerMode :: CompilerMode-    } deriving (Eq,Show,Read)--data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read)--defaultState :: GhcModState-defaultState = GhcModState Simple---------------------------------------------------------------------- | This is basically a newtype wrapper around 'StateT', 'ErrorT', 'JournalT'--- and 'ReaderT' with custom instances for 'GhcMonad' and it's constraints that--- means you can run (almost) all functions from the GHC API on top of 'GhcModT'--- transparently.------ The inner monad @m@ should have instances for 'MonadIO' and--- 'MonadBaseControl' 'IO', in the common case this is simply 'IO'. Most @mtl@--- monads already have 'MonadBaseControl' 'IO' instances, see the--- @monad-control@ package.-newtype GhcModT m a = GhcModT {-      unGhcModT :: StateT GhcModState-                     (ErrorT GhcModError-                       (JournalT GhcModLog-                         (ReaderT GhcModEnv m) ) ) a-    } deriving ( Functor-               , Applicative-               , Alternative-               , Monad-               , MonadPlus-#if DIFFERENT_MONADIO-               , Control.Monad.IO.Class.MonadIO-#endif-               , MonadReader GhcModEnv -- TODO: make MonadReader instance-                                       -- pass-through like MonadState-               , MonadWriter w-               , MonadError GhcModError-               )--instance MonadIO m => MonadIO (GhcModT m) where-    liftIO action = do-      res <- GhcModT . liftIO . liftIO . liftIO . liftIO $ try action-      case res of-        Right a -> return a--        Left e | isIOError e ->-                   throwError $ GMEIOException (fromEx e :: IOError)-        Left e | isGhcModError e ->-                   throwError $ (fromEx e :: GhcModError)-        Left e -> throw e--     where-       fromEx :: Exception e => SomeException -> e-       fromEx se = let Just e = fromException se in e-       isIOError se =-           case fromException se of-             Just (_ :: IOError) -> True-             Nothing -> False--       isGhcModError se =-           case fromException se of-             Just (_ :: GhcModError) -> True-             Nothing -> False---instance MonadTrans (GhcModT) where-    lift = GhcModT . lift . lift . lift . lift--instance MonadState s m => MonadState s (GhcModT m) where-    get = GhcModT $ lift $ lift $ lift get-    put = GhcModT . lift . lift . lift . put-    state = GhcModT . lift . lift . lift . state---#if MONADIO_INSTANCES-instance MonadIO m => MonadIO (StateT s m) where-    liftIO = lift . liftIO--instance MonadIO m => MonadIO (ReaderT r m) where-    liftIO = lift . liftIO+import Control.Applicative -instance (Monoid w, MonadIO m) => MonadIO (JournalT w m) where-    liftIO = lift . liftIO+import Control.Concurrent -instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where-    liftIO = lift . liftIO+import Control.Monad.Reader (runReaderT)+import Control.Monad.State.Strict (runStateT)+import Control.Monad.Trans.Journal (runJournalT) -instance MonadIO m => MonadIO (MaybeT m) where-    liftIO = lift . liftIO-#endif+import Exception (ExceptionMonad(..)) -----------------------------------------------------------------+import System.Directory+import Prelude --- | Initialize the 'DynFlags' relating to the compilation of a single--- file or GHC session according to the 'Cradle' and 'Options'--- provided.-initializeFlagsWithCradle :: (IOish m, GhcMonad m, MonadError GhcModError m)-        => Options-        -> Cradle-        -> m ()-initializeFlagsWithCradle opt c-  | cabal     = withCabal-  | otherwise = withSandbox-  where-    mCabalFile = cradleCabalFile c-    cabal = isJust mCabalFile-    ghcopts = ghcUserOptions opt-    withCabal = do-        let Just cabalFile = mCabalFile-        pkgDesc <- parseCabalFile c cabalFile-        compOpts <- getCompilerOptions ghcopts c pkgDesc-        initSession CabalPkg opt compOpts-    withSandbox = initSession SingleFile opt compOpts-      where-        importDirs = [".","..","../..","../../..","../../../..","../../../../.."]-        pkgOpts = ghcDbStackOpts $ cradlePkgDbStack c-        compOpts-          | null pkgOpts = CompilerOptions ghcopts importDirs []-          | otherwise    = CompilerOptions (ghcopts ++ pkgOpts) [wdir,rdir] []-        wdir = cradleCurrentDir c-        rdir = cradleRootDir    c+withCradle :: IOish m => FilePath -> (Cradle -> m a) -> m a+withCradle cradledir f =+    gbracket (liftIO $ findCradle' cradledir) (liftIO . cleanupCradle) f -initSession :: GhcMonad m-            => Build-            -> Options-            -> CompilerOptions-            -> m ()-initSession build Options {..} CompilerOptions {..} = do-    df <- G.getSessionDynFlags-    void $ G.setSessionDynFlags =<< addCmdOpts ghcOptions-      ( setModeSimple-      $ Gap.setFlags-      $ setIncludeDirs includeDirs-      $ setBuildEnv build-      $ setEmptyLogger-      $ Gap.addPackageFlags depPackages df)+withGhcModEnv :: IOish m => FilePath -> Options -> (GhcModEnv -> m a) -> m a+withGhcModEnv dir opt f = withCradle dir (withGhcModEnv' opt f) -----------------------------------------------------------------+withGhcModEnv' :: IOish m => Options -> (GhcModEnv -> m a) -> Cradle -> m a+withGhcModEnv' opt f crdl = do+    olddir <- liftIO getCurrentDirectory+    c <- liftIO newChan+    let outp = case linePrefix opt of+                 Just _ -> GmOutputChan c+                 Nothing -> GmOutputStdio+    gbracket_ (setup c) (teardown olddir) (f $ GhcModEnv opt crdl outp)+ where+   setup c = liftIO $ do+     setCurrentDirectory $ cradleRootDir crdl+     forkIO $ stdoutGateway c -newGhcModEnv :: Options -> FilePath -> IO GhcModEnv-newGhcModEnv opt dir = do-      session <- newIORef (error "empty session")-      c <- findCradle' dir-      return GhcModEnv {-          gmGhcSession = session-        , gmOptions = opt-        , gmCradle = c-        }+   teardown olddir tid = liftIO $ do+     setCurrentDirectory olddir+     killThread tid -cleanupGhcModEnv :: GhcModEnv -> IO ()-cleanupGhcModEnv env = cleanupCradle $ gmCradle env+   gbracket_ ma mb mc = gbracket ma mb (const mc)  -- | Run a @GhcModT m@ computation. runGhcModT :: IOish m            => Options            -> GhcModT m a            -> m (Either GhcModError a, GhcModLog)-runGhcModT opt action = gbracket newEnv delEnv $ \env -> do-    r <- first (fst <$>) <$> (runGhcModT' env defaultState $ do-        dflags <- getSessionDynFlags-        defaultCleanupHandler dflags $ do-            initializeFlagsWithCradle opt (gmCradle env)-            action)-    return r+runGhcModT opt action = do+    dir <- liftIO getCurrentDirectory+    runGhcModT' dir opt action - where-   newEnv = liftBase $ newGhcModEnv opt =<< getCurrentDirectory-   delEnv = liftBase . cleanupGhcModEnv+runGhcModT' :: IOish m+            => FilePath+            -> Options+            -> GhcModT m a+            -> m (Either GhcModError a, GhcModLog)+runGhcModT' dir opt action = liftIO (canonicalizePath dir) >>= \dir' ->+    withGhcModEnv dir' opt $ \env ->+      first (fst <$>) <$> runGhcModT'' env defaultGhcModState+        (gmSetLogLevel (logLevel opt) >> action)  -- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT -- computation. Note that if the computation that returned @result@ modified the@@ -292,7 +103,7 @@              => (Either GhcModError a, GhcModLog)              -> GhcModT m a hoistGhcModT (r,l) = do-  GhcModT (lift $ lift $ journal l) >> case r of+  gmlJournal l >> case r of     Left e -> throwError e     Right a -> return a @@ -301,179 +112,10 @@ -- do with 'GhcModEnv' and 'GhcModState'. -- -- You should probably look at 'runGhcModT' instead.-runGhcModT' :: IOish m-           => GhcModEnv-           -> GhcModState-           -> GhcModT m a-           -> m (Either GhcModError (a, GhcModState), GhcModLog)-runGhcModT' r s a = do-  (res, w') <--      flip runReaderT r $ runJournalT $ runErrorT $-        runStateT (unGhcModT $ initGhcMonad (Just libdir) >> a) s-  return (res, w')-------------------------------------------------------------------- | Make a copy of the 'gmGhcSession' IORef, run the action and restore the--- original 'HscEnv'.-withTempSession :: IOish m => GhcModT m a -> GhcModT m a-withTempSession action = do-  session <- gmGhcSession <$> ask-  savedHscEnv <- liftIO $ readIORef session-  a <- action-  liftIO $ writeIORef session savedHscEnv-  return a---- | This is a very ugly workaround don't use it.-overrideGhcUserOptions :: IOish m => ([GHCOption] -> GhcModT m b) -> GhcModT m b-overrideGhcUserOptions action = withTempSession $ do-  env <- ask-  opt <- options-  let ghcOpts = ghcUserOptions opt-      opt' = opt { ghcUserOptions = [] }--  initializeFlagsWithCradle opt' (gmCradle env)--  action ghcOpts--------------------------------------------------------------------gmeAsk :: IOish m => GhcModT m GhcModEnv-gmeAsk = ask--gmsGet :: IOish m => GhcModT m GhcModState-gmsGet = GhcModT get--gmsPut :: IOish m => GhcModState -> GhcModT m ()-gmsPut = GhcModT . put--options :: IOish m => GhcModT m Options-options = gmOptions <$> gmeAsk--cradle :: IOish m => GhcModT m Cradle-cradle = gmCradle <$> gmeAsk--getCompilerMode :: IOish m => GhcModT m CompilerMode-getCompilerMode = gmCompilerMode <$> gmsGet--setCompilerMode :: IOish m => CompilerMode -> GhcModT m ()-setCompilerMode mode = (\s -> gmsPut s { gmCompilerMode = mode } ) =<< gmsGet--------------------------------------------------------------------withOptions :: IOish m => (Options -> Options) -> GhcModT m a -> GhcModT m a-withOptions changeOpt action = local changeEnv action-  where-    changeEnv e = e { gmOptions = changeOpt opt }-      where-        opt = gmOptions e--------------------------------------------------------------------instance (MonadBaseControl IO m) => MonadBase IO (GhcModT m) where-    liftBase = GhcModT . liftBase--#if MIN_VERSION_monad_control(1,0,0)--instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where-    type StM (GhcModT m) a =-          StM (StateT GhcModState-                (ErrorT GhcModError-                  (JournalT GhcModLog-                    (ReaderT GhcModEnv m) ) ) ) a-    liftBaseWith f = GhcModT . liftBaseWith $ \runInBase ->-        f $ runInBase . unGhcModT--    restoreM = GhcModT . restoreM-    {-# INLINE liftBaseWith #-}-    {-# INLINE restoreM #-}--#else--instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where-    newtype StM (GhcModT m) a = StGhcMod {-          unStGhcMod :: StM (StateT GhcModState-                              (ErrorT GhcModError-                                (JournalT GhcModLog-                                  (ReaderT GhcModEnv m) ) ) ) a }-    liftBaseWith f = GhcModT . liftBaseWith $ \runInBase ->-        f $ liftM StGhcMod . runInBase . unGhcModT--    restoreM = GhcModT . restoreM . unStGhcMod-    {-# INLINE liftBaseWith #-}-    {-# INLINE restoreM #-}--#endif---- GHC cannot prove the following instances to be decidable automatically using--- the FlexibleContexts extension as they violate the second Paterson Condition,--- namely that: The assertion has fewer constructors and variables (taken--- together and counting repetitions) than the head. Specifically the--- @MonadBaseControl IO m@ constraint is causing this violation.------ Proof of termination:------ Assuming all constraints containing the variable `m' exist and are decidable--- we show termination by manually replacing the current set of constraints with--- their own set of constraints and show that this, after a finite number of--- steps, results in the empty set, i.e. not having to check any more--- constraints.------ We start by setting the constraints to be those immediate constraints of the--- instance declaration which cannot be proven decidable automatically for the--- type under consideration.------ @--- { MonadBaseControl IO m }--- @------ Classes used:------ * @class MonadBase b m => MonadBaseControl b m@------ @--- { MonadBase IO m }--- @------ Classes used:------ * @class (Applicative b, Applicative m, Monad b, Monad m) => MonadBase b m@------ @--- { Applicative IO, Applicative m, Monad IO, Monad m }--- @------ Classes used:------ * @class Monad m@--- * @class Applicative f => Functor f@------ @--- { Functor m }--- @------ Classes used:------ * @class Functor f@------ @--- { }--- @--- ∎--instance (Functor m, MonadIO m, MonadBaseControl IO m)-      => GhcMonad (GhcModT m) where-    getSession = (liftIO . readIORef) . gmGhcSession =<< ask-    setSession a = (liftIO . flip writeIORef a) . gmGhcSession =<< ask--#if __GLASGOW_HASKELL__ >= 706-instance (Functor m, MonadIO m, MonadBaseControl IO m)-      => HasDynFlags (GhcModT m) where-    getDynFlags = getSessionDynFlags-#endif--instance (MonadIO m, MonadBaseControl IO m)-      => ExceptionMonad (GhcModT m) where-    gcatch act handler = control $ \run ->-        run act `gcatch` (run . handler)--    gmask = liftBaseOp gmask . liftRestore-     where liftRestore f r = f $ liftBaseOp_ r+runGhcModT'' :: IOish m+             => GhcModEnv+             -> GhcModState+             -> GhcModT m a+             -> m (Either GhcModError (a, GhcModState), GhcModLog)+runGhcModT'' r s a = do+  flip runReaderT r $ runJournalT $ runErrorT $ runStateT (unGhcModT a) s

@@ -0,0 +1,442 @@+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-}+{-# LANGUAGE TypeFamilies, UndecidableInstances, BangPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Language.Haskell.GhcMod.Monad.Types (+  -- * Monad Types+    GhcModT(..)+  , GmlT(..)+  , LightGhc(..)+  , GmGhc+  , IOish+  -- * Environment, state and logging+  , GhcModEnv(..)+  , GhcModState(..)+  , GhcModCaches(..)+  , defaultGhcModState+  , GmGhcSession(..)+  , GmComponent(..)+  , CompilerMode(..)+  -- * Accessing 'GhcModEnv', 'GhcModState' and 'GhcModLog'+  , GmLogLevel(..)+  , GhcModLog(..)+  , GhcModError(..)+  , Gm+  , GmEnv(..)+  , GmState(..)+  , GmLog(..)+  , cradle+  , options+  , withOptions+  , getCompilerMode+  , setCompilerMode+  -- * Re-exporting convenient stuff+  , MonadIO+  , liftIO+  , gmlGetSession+  , gmlSetSession+  ) where++-- MonadUtils of GHC 7.6 or earlier defines its own MonadIO.+-- RWST does not automatically become an instance of MonadIO.+-- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class.+-- So, RWST automatically becomes an instance of+#if __GLASGOW_HASKELL__ < 708+-- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different+-- classes before ghc 7.8+#define DIFFERENT_MONADIO 1++-- RWST doen't have a MonadIO instance before ghc 7.8+#define MONADIO_INSTANCES 1+#endif++import Language.Haskell.GhcMod.Types++import GHC+import DynFlags+import Exception+import HscTypes++import Control.Applicative+import Control.Monad++import Control.Monad.Reader (ReaderT(..))+import Control.Monad.Error (ErrorT(..), MonadError(..))+import Control.Monad.State.Strict (StateT(..))+import Control.Monad.Trans.Journal (JournalT)+import Control.Monad.Trans.Maybe (MaybeT(..))++import Control.Monad.Base (MonadBase(..), liftBase)+import Control.Monad.Trans.Control++import Control.Monad.Reader.Class+import Control.Monad.Writer.Class+import Control.Monad.State.Class (MonadState(..))+import Control.Monad.Journal.Class (MonadJournal(..))+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Error (Error(..))+import qualified Control.Monad.IO.Class as MTL++#if DIFFERENT_MONADIO+import Data.Monoid (Monoid)+#endif++import Data.Maybe+import Data.Monoid+import Data.IORef+import Prelude++import qualified MonadUtils as GHC (MonadIO(..))++-- | This is basically a newtype wrapper around 'StateT', 'ErrorT', 'JournalT'+-- and 'ReaderT' with custom instances for 'GhcMonad' and it's constraints that+-- means you can run (almost) all functions from the GHC API on top of 'GhcModT'+-- transparently.+--+-- The inner monad @m@ should have instances for 'MonadIO' and+-- 'MonadBaseControl' 'IO', in the common case this is simply 'IO'. Most @mtl@+-- monads already have 'MonadBaseControl' 'IO' instances, see the+-- @monad-control@ package.+newtype GhcModT m a = GhcModT {+      unGhcModT :: StateT GhcModState+                     (ErrorT GhcModError+                       (JournalT GhcModLog+                         (ReaderT GhcModEnv m) ) ) a+    } deriving ( Functor+               , Applicative+               , Alternative+               , Monad+               , MonadPlus+               , MTL.MonadIO+#if DIFFERENT_MONADIO+               , GHC.MonadIO+#endif+               , MonadError GhcModError+               )++newtype GmlT m a = GmlT { unGmlT :: GhcModT m a }+    deriving ( Functor+             , Applicative+             , Alternative+             , Monad+             , MonadPlus+             , MonadTrans+             , MTL.MonadIO+#if DIFFERENT_MONADIO+             , GHC.MonadIO+#endif+             , MonadError GhcModError+             , GmEnv+             , GmState+             , GmLog+             )++newtype LightGhc a = LightGhc { unLightGhc :: ReaderT (IORef HscEnv) IO a }+    deriving ( Functor+             , Applicative+             , Monad+             , MTL.MonadIO+#if DIFFERENT_MONADIO+             , GHC.MonadIO+#endif+             )++#if DIFFERENT_MONADIO+instance MTL.MonadIO m => GHC.MonadIO (ReaderT x m) where+    liftIO = MTL.liftIO+instance MTL.MonadIO m => GHC.MonadIO (StateT x m) where+    liftIO = MTL.liftIO+instance (Error e, MTL.MonadIO m) => GHC.MonadIO (ErrorT e m) where+    liftIO = MTL.liftIO+instance MTL.MonadIO m => GHC.MonadIO (JournalT x m) where+    liftIO = MTL.liftIO+instance MTL.MonadIO m => GHC.MonadIO (MaybeT m) where+    liftIO = MTL.liftIO+#endif++instance MonadIO IO where+    liftIO = id+instance MonadIO m => MonadIO (ReaderT x m) where+    liftIO = MTL.liftIO+instance MonadIO m => MonadIO (StateT x m) where+    liftIO = MTL.liftIO+instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where+    liftIO = MTL.liftIO+instance MonadIO m => MonadIO (JournalT x m) where+    liftIO = MTL.liftIO+instance MonadIO m => MonadIO (MaybeT m) where+    liftIO = MTL.liftIO+instance MonadIOC m => MonadIO (GhcModT m) where+    liftIO = MTL.liftIO+instance MonadIOC m => MonadIO (GmlT m) where+    liftIO = MTL.liftIO+instance MonadIO LightGhc where+    liftIO = MTL.liftIO++class Monad m => GmEnv m where+    gmeAsk :: m GhcModEnv+    gmeAsk = gmeReader id++    gmeReader :: (GhcModEnv -> a) -> m a+    gmeReader f = f `liftM` gmeAsk++    gmeLocal :: (GhcModEnv -> GhcModEnv) -> m a -> m a+    {-# MINIMAL (gmeAsk | gmeReader), gmeLocal #-}++type Gm m = (GmEnv m, GmState m, GmLog m)++instance Monad m => GmEnv (GhcModT m) where+    gmeAsk = GhcModT ask+    gmeReader = GhcModT . reader+    gmeLocal f a = GhcModT $ local f (unGhcModT a)++instance GmEnv m => GmEnv (StateT s m) where+    gmeAsk = lift gmeAsk+    gmeReader = lift . gmeReader+    gmeLocal f (StateT a) = StateT $ \s -> gmeLocal f (a s)++class Monad m => GmState m where+    gmsGet :: m GhcModState+    gmsGet = gmsState (\s -> (s, s))++    gmsPut :: GhcModState -> m ()+    gmsPut s = gmsState (\_ -> ((), s))++    gmsState :: (GhcModState -> (a, GhcModState)) -> m a+    gmsState f = do+      s <- gmsGet+      let ~(a, s') = f s+      gmsPut s'+      return a+    {-# MINIMAL gmsState | gmsGet, gmsPut #-}++instance Monad m => GmState (StateT GhcModState m) where+    gmsGet = get+    gmsPut = put+    gmsState = state++instance Monad m => GmState (GhcModT m) where+    gmsGet = GhcModT get+    gmsPut = GhcModT . put+    gmsState = GhcModT . state++instance GmState m => GmState (MaybeT m) where+    gmsGet = MaybeT $ Just `liftM` gmsGet+    gmsPut = MaybeT . (Just `liftM`) . gmsPut+    gmsState = MaybeT . (Just `liftM`) . gmsState++class Monad m => GmLog m where+    gmlJournal :: GhcModLog -> m ()+    gmlHistory :: m GhcModLog+    gmlClear   :: m ()++instance Monad m => GmLog (JournalT GhcModLog m) where+    gmlJournal = journal+    gmlHistory = history+    gmlClear   = clear++instance Monad m => GmLog (GhcModT m) where+    gmlJournal = GhcModT . lift . lift . journal+    gmlHistory = GhcModT $ lift $ lift history+    gmlClear   = GhcModT $ lift $ lift clear++instance (Monad m, GmLog m) => GmLog (ReaderT r m) where+    gmlJournal = lift . gmlJournal+    gmlHistory = lift gmlHistory+    gmlClear = lift  gmlClear++instance (Monad m, GmLog m) => GmLog (StateT s m) where+    gmlJournal = lift . gmlJournal+    gmlHistory = lift gmlHistory+    gmlClear = lift gmlClear++instance Monad m => MonadJournal GhcModLog (GhcModT m) where+  journal !w = GhcModT $ lift $ lift $ (journal w)+  history    = GhcModT $ lift $ lift $ history+  clear      = GhcModT $ lift $ lift $ clear++instance MonadTrans GhcModT where+    lift = GhcModT . lift . lift . lift . lift++instance forall r m. MonadReader r m => MonadReader r (GhcModT m) where+    local f ma = gmLiftWithInner (\run -> local f (run ma))+    ask = gmLiftInner ask++instance (Monoid w, MonadWriter w m) => MonadWriter w (GhcModT m) where+    tell = gmLiftInner . tell+    listen ma =+      liftWith (\run -> listen (run ma)) >>= \(sta, w) ->+          flip (,) w `liftM` restoreT (return sta)++    pass maww = maww >>= gmLiftInner . pass . return++instance MonadState s m => MonadState s (GhcModT m) where+    get = GhcModT $ lift $ lift $ lift get+    put = GhcModT . lift . lift . lift . put+    state = GhcModT . lift . lift . lift . state++instance (MonadBaseControl IO m) => MonadBase IO (GmlT m) where+    liftBase = GmlT . liftBase++instance (MonadBaseControl IO m) => MonadBaseControl IO (GmlT m) where+    type StM (GmlT m) a = StM (GhcModT m) a+    liftBaseWith = defaultLiftBaseWith+    restoreM = defaultRestoreM+    {-# INLINE liftBaseWith #-}+    {-# INLINE restoreM #-}++instance MonadTransControl GmlT where+    type StT GmlT a = StT GhcModT a+    liftWith = defaultLiftWith GmlT unGmlT+    restoreT = defaultRestoreT GmlT++instance (MonadBaseControl IO m) => MonadBase IO (GhcModT m) where+    liftBase = GhcModT . liftBase++instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where+    type StM (GhcModT m) a =+          StM (StateT GhcModState+                (ErrorT GhcModError+                  (JournalT GhcModLog+                    (ReaderT GhcModEnv m) ) ) ) a++    liftBaseWith f = GhcModT (liftBaseWith $ \runInBase ->+        f $ runInBase . unGhcModT)++    restoreM = GhcModT . restoreM+    {-# INLINE liftBaseWith #-}+    {-# INLINE restoreM #-}++instance MonadTransControl GhcModT where+    type StT GhcModT a = (Either GhcModError (a, GhcModState), GhcModLog)++    liftWith f = GhcModT $+      liftWith $ \runS ->+        liftWith $ \runE ->+          liftWith $ \runJ ->+            liftWith $ \runR ->+              f $ \ma -> runR $ runJ $ runE $ runS $ unGhcModT ma+    restoreT = GhcModT . restoreT . restoreT . restoreT . restoreT+    {-# INLINE liftWith #-}+    {-# INLINE restoreT #-}++gmLiftInner :: Monad m => m a -> GhcModT m a+gmLiftInner = GhcModT . lift . lift . lift . lift++gmLiftWithInner :: (MonadTransControl t, Monad m, Monad (t m))+                => (Run t -> m (StT t a)) -> t m a+gmLiftWithInner f = liftWith f >>= restoreT . return++-- GHC cannot prove the following instances to be decidable automatically using+-- the FlexibleContexts extension as they violate the second Paterson Condition,+-- namely that: The assertion has fewer constructors and variables (taken+-- together and counting repetitions) than the head. Specifically the+-- @MonadBaseControl IO m@ constraint in 'IOish' is causing this violation.++type GmGhc m = (IOish m, GhcMonad m)++instance (MonadIO m, MonadBaseControl IO m) => GhcMonad (GmlT m) where+    getSession = gmlGetSession+    setSession = gmlSetSession++-- ---------------------------------------------------------------------++gmlGetSession :: (MonadIO m, MonadBaseControl IO m) => GmlT m HscEnv+gmlGetSession = do+        ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet+        GHC.liftIO $ readIORef ref++gmlSetSession :: (MonadIO m, MonadBaseControl IO m) => HscEnv -> GmlT m ()+gmlSetSession a = do+        ref <- gmgsSession . fromJust . gmGhcSession <$> gmsGet+        GHC.liftIO $ flip writeIORef a ref++-- ---------------------------------------------------------------------+instance GhcMonad LightGhc where+    getSession = (GHC.liftIO . readIORef) =<< LightGhc ask+    setSession a = (GHC.liftIO . flip writeIORef a) =<< LightGhc ask++#if __GLASGOW_HASKELL__ >= 706+instance (MonadIO m, MonadBaseControl IO m) => HasDynFlags (GmlT m) where+    getDynFlags = hsc_dflags <$> getSession++instance HasDynFlags LightGhc where+    getDynFlags = hsc_dflags <$> getSession+#endif++instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GhcModT m) where+    gcatch act handler = control $ \run ->+        run act `gcatch` (run . handler)++    gmask = liftBaseOp gmask . liftRestore+     where liftRestore f r = f $ liftBaseOp_ r++instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (GmlT m) where+    gcatch act handler = control $ \run ->+        run act `gcatch` (run . handler)++    gmask = liftBaseOp gmask . liftRestore+     where liftRestore f r = f $ liftBaseOp_ r++instance ExceptionMonad LightGhc where+  gcatch act handl =+      LightGhc $ unLightGhc act `gcatch` \e -> unLightGhc (handl e)+  gmask f =+      LightGhc $ gmask $ \io_restore ->let+          g_restore (LightGhc m) = LightGhc $ io_restore m+      in+        unLightGhc (f g_restore)+++instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (StateT s m) where+    gcatch act handler = control $ \run ->+        run act `gcatch` (run . handler)++    gmask = liftBaseOp gmask . liftRestore+     where liftRestore f r = f $ liftBaseOp_ r++instance (MonadIO m, MonadBaseControl IO m) => ExceptionMonad (ReaderT s m) where+    gcatch act handler = control $ \run ->+        run act `gcatch` (run . handler)++    gmask = liftBaseOp gmask . liftRestore+     where liftRestore f r = f $ liftBaseOp_ r++----------------------------------------------------------------++options :: GmEnv m => m Options+options = gmOptions `liftM` gmeAsk++cradle :: GmEnv m => m Cradle+cradle = gmCradle `liftM` gmeAsk++getCompilerMode :: GmState m => m CompilerMode+getCompilerMode = gmCompilerMode `liftM` gmsGet++setCompilerMode :: GmState m => CompilerMode -> m ()+setCompilerMode mode = (\s -> gmsPut s { gmCompilerMode = mode } ) =<< gmsGet++withOptions :: GmEnv m => (Options -> Options) -> m a -> m a+withOptions changeOpt action = gmeLocal changeEnv action+  where+    changeEnv e = e { gmOptions = changeOpt opt }+      where+        opt = gmOptions e

@@ -0,0 +1,199 @@+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++-- Derived from process:System.Process+-- Copyright (c) The University of Glasgow 2004-2008++module Language.Haskell.GhcMod.Output (+    gmPutStr+  , gmErrStr+  , gmPutStrLn+  , gmErrStrLn+  , gmUnsafePutStrLn+  , gmUnsafeErrStrLn+  , gmReadProcess+  , stdoutGateway+  ) where++import Data.List+import System.IO+import System.Exit+import System.Process+import Control.Monad+import Control.DeepSeq+import Control.Exception+import Control.Concurrent++import Language.Haskell.GhcMod.Types hiding (LineSeparator)+import Language.Haskell.GhcMod.Monad.Types++withLines :: (String -> String) -> String -> String+withLines f s = let+    res = unlines $ map f $ lines s+  in+    case s of+      [] -> res+      _ | not $ isTerminated s ->+            reverse $ drop 1 $ reverse res+      _ -> res++isTerminated :: String -> Bool+isTerminated "" = False+isTerminated s = isNewline (last s)++isNewline :: Char -> Bool+isNewline c = c == '\n'++toGmLines :: String -> (GmLines String)+toGmLines "" = GmLines GmPartial ""+toGmLines s | isNewline (last s) = GmLines GmTerminated s+toGmLines s = GmLines GmPartial s++outputFns :: (GmEnv m, MonadIO m')+          => m (GmLines String -> m' (), GmLines String -> m' ())+outputFns = do+  opts <- options+  env <- gmeAsk+  return $ outputFns' opts (gmOutput env)++outputFns' :: MonadIO m'+           => Options+           -> GmOutput+           -> (GmLines String -> m' (), GmLines String -> m' ())+outputFns' opts output  = let+  Options {..} = opts++  pfx f = withLines f++  outPfx, errPfx :: GmLines String -> GmLines String+  (outPfx, errPfx) =+      case linePrefix of+        Nothing -> ( id, id )+        Just (op, ep) -> ( fmap $ pfx (op++), fmap $ pfx (ep++) )+ in+  case output of+    GmOutputStdio  ->+        ( liftIO . putStr         . unGmLine . outPfx+        , liftIO . hPutStr stderr . unGmLine . errPfx)+    GmOutputChan c ->+        ( liftIO . writeChan c . (,) GmOut . outPfx+        , liftIO . writeChan c . (,) GmErr .errPfx)++gmPutStr, gmPutStrLn, gmErrStr, gmErrStrLn+    :: (MonadIO m, GmEnv m) => String -> m ()++gmPutStr str = do+  putOut <- fst `liftM` outputFns+  putOut $ toGmLines str++gmPutStrLn = gmPutStr . (++"\n")+gmErrStrLn = gmErrStr . (++"\n")++gmErrStr str = do+  putErr <- snd `liftM` outputFns+  putErr $ toGmLines str++-- | Only use these when you're sure there are no other writers on stdout+gmUnsafePutStrLn, gmUnsafeErrStrLn+    :: MonadIO m => Options -> String -> m ()+gmUnsafePutStrLn opts = (fst $ outputFns' opts GmOutputStdio) . toGmLines+gmUnsafeErrStrLn opts = (snd $ outputFns' opts GmOutputStdio) . toGmLines++gmReadProcess :: GmEnv m => m (FilePath -> [String] -> String -> IO String)+gmReadProcess = do+  GhcModEnv {..} <- gmeAsk+  case gmOutput of+    GmOutputChan _ ->+        readProcessStderrChan+    GmOutputStdio ->+        return $ readProcess++stdoutGateway :: Chan (GmStream, GmLines String) -> IO ()+stdoutGateway chan = go ("", "")+ where+   go buf@(obuf, ebuf) = do+     (stream, GmLines ty l) <- readChan chan+     case ty of+       GmTerminated ->+           case stream of+             GmOut -> putStr (obuf++l) >> go ("", ebuf)+             GmErr -> putStr (ebuf++l) >> go (obuf, "")+       GmPartial -> case reverse $ lines l of+                      [] -> go buf+                      [x] -> go (appendBuf stream buf x)+                      x:xs -> do+                        putStr $ unlines $ reverse xs+                        go (appendBuf stream buf x)++   appendBuf GmOut (obuf, ebuf) s = (obuf++s, ebuf)+   appendBuf GmErr (obuf, ebuf) s = (obuf, ebuf++s)+++readProcessStderrChan ::+    GmEnv m => m (FilePath -> [String] -> String -> IO String)+readProcessStderrChan = do+  (_, e) <- outputFns+  return $ go e+ where+   go :: (GmLines String -> IO ()) -> FilePath -> [String] -> String -> IO String+   go putErr exe args input = do+     let cp = (proc exe args) {+                std_out = CreatePipe+              , std_err = CreatePipe+              , std_in  = CreatePipe+              }+     (Just i, Just o, Just e, h) <- createProcess cp++     _ <- forkIO $ reader e++     output  <- hGetContents o+     withForkWait (evaluate $ rnf output) $ \waitOut -> do++       -- now write any input+       unless (null input) $+         ignoreSEx $ hPutStr i input+       -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE+       ignoreSEx $ hClose i++       -- wait on the output+       waitOut+       hClose o++     res <- waitForProcess h+     case res of+       ExitFailure rv ->+           processFailedException "readProcessStderrChan" exe args rv+       ExitSuccess ->+           return output+    where+      ignoreSEx = handle (\(SomeException _) -> return ())+      reader h = ignoreSEx $ do+        putErr . toGmLines . (++"\n") =<< hGetLine h+        reader h++withForkWait :: IO () -> (IO () ->  IO a) -> IO a+withForkWait async body = do+  waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))+  mask $ \restore -> do+    tid <- forkIO $ try (restore async) >>= putMVar waitVar+    let wait = takeMVar waitVar >>= either throwIO return+    restore (body wait) `onException` killThread tid++processFailedException :: String -> String -> [String] -> Int -> IO a+processFailedException fn exe args rv =+      error $ concat [ fn, ": ", exe, " "+                     , intercalate " " (map show args)+                     , " (exit " ++ show rv ++ ")"]

@@ -1,21 +1,42 @@-{-# LANGUAGE BangPatterns, TupleSections #-}-module Language.Haskell.GhcMod.PathsAndFiles where+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>. +module Language.Haskell.GhcMod.PathsAndFiles (+    module Language.Haskell.GhcMod.PathsAndFiles+  , module Language.Haskell.GhcMod.Caching+  ) where++import Config (cProjectVersion) import Control.Applicative import Control.Monad import Data.List import Data.Char import Data.Maybe-import Data.Traversable (traverse)-import Language.Haskell.GhcMod.Types+import Data.Traversable hiding (mapM)+import Distribution.Helper (buildPlatform) import System.Directory import System.FilePath+import System.Process +import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Error+import Language.Haskell.GhcMod.Caching import qualified Language.Haskell.GhcMod.Utils as U--import Distribution.Simple.BuildPaths (defaultDistPref)-import Distribution.Simple.Configure (localBuildInfoFile)+import Utils (mightExist)+import Prelude  -- | Guaranteed to be a path to a directory with no trailing slash. type DirPath = FilePath@@ -23,40 +44,111 @@ -- | Guaranteed to be the name of a file only (no slashes). type FileName = String +newtype UnString = UnString { unString :: String }++instance Show UnString where+    show = unString++instance Read UnString where+    readsPrec _ = \str -> [(UnString str, "")]+ -- | @findCabalFiles dir@. Searches for a @.cabal@ files in @dir@'s parent -- directories. The first parent directory containing more than one cabal file -- is assumed to be the project directory. If only one cabal file exists in this -- directory it is returned otherwise @findCabalFiles@ throws 'GMENoCabalFile' -- or 'GMETooManyCabalFiles' findCabalFile :: FilePath -> IO (Maybe FilePath)-findCabalFile directory = do-    -- Look for cabal files in @dir@ and all it's parent directories-    dcs <- getCabalFiles `zipMapM` parents directory-    -- Extract first non-empty list, which represents a directory with cabal-    -- files.-    case find (not . null) $ uncurry appendDir `map` dcs of-      Just []          -> throw $ GMENoCabalFile+findCabalFile dir = do+    -- List of directories and all cabal file candidates+    dcs <- findFileInParentsP  isCabalFile dir :: IO ([(DirPath, [FileName])])+    let css = uncurry appendDir `map` dcs :: [[FilePath]]+    case find (not . null) css of+      Nothing -> return Nothing       Just cfs@(_:_:_) -> throw $ GMETooManyCabalFiles cfs-      a  -> return $ head <$> a+      Just (a:_)       -> return (Just a)+      Just []          -> error "findCabalFile"  where    appendDir :: DirPath -> [FileName] -> [FilePath]-   appendDir dir fs = (dir </>) `map` fs+   appendDir d fs = (d </>) `map` fs --- | @getCabalFiles dir@. Find all files ending in @.cabal@ in @dir@.-getCabalFiles :: DirPath -> IO [FileName]-getCabalFiles dir =-    filterM isCabalFile =<< getDirectoryContents dir+-- | Get path to sandbox config file+getSandboxDb :: FilePath+             -- ^ Path to the cabal package root directory (containing the+             -- @cabal.sandbox.config@ file)+             -> IO (Maybe GhcPkgDb)+getSandboxDb d = do+  mConf <- traverse readFile =<< mightExist (d </> "cabal.sandbox.config")+  bp <- buildPlatform readProcess+  return $ PackageDb . fixPkgDbVer bp <$> (extractSandboxDbDir =<< mConf)+  where-   isCabalFile f = do-     exists <- doesFileExist $ dir </> f-     return (exists && takeExtension' f == ".cabal")+   fixPkgDbVer bp dir =+       case takeFileName dir == ghcSandboxPkgDbDir bp of+         True -> dir+         False -> takeDirectory dir </> ghcSandboxPkgDbDir bp -   takeExtension' p = if takeFileName p == takeExtension p-                        then ""-                        else takeExtension p+-- | Extract the sandbox package db directory from the cabal.sandbox.config+-- file. Exception is thrown if the sandbox config file is broken.+extractSandboxDbDir :: String -> Maybe FilePath+extractSandboxDbDir conf = extractValue <$> parse conf+  where+    key = "package-db:"+    keyLen = length key +    parse = listToMaybe . filter (key `isPrefixOf`) . lines+    extractValue = U.dropWhileEnd isSpace . dropWhile isSpace . drop keyLen+++-- |+-- >>> isCabalFile "/home/user/.cabal"+-- False+isCabalFile :: FilePath -> Bool+isCabalFile f = takeExtension' f == ".cabal"++-- |+-- >>> takeExtension' "/some/dir/bla.cabal"+-- ".cabal"+--+-- >>> takeExtension' "some/reldir/bla.cabal"+-- ".cabal"+--+-- >>> takeExtension' "bla.cabal"+-- ".cabal"+--+-- >>> takeExtension' ".cabal"+-- ""+takeExtension' :: FilePath -> String+takeExtension' p =+    if takeFileName p == takeExtension p+      then "" -- just ".cabal" is not a valid cabal file+      else takeExtension p++-- | @findFileInParentsP p dir@ Look for files satisfying @p@ in @dir@ and all+-- it's parent directories.+findFileInParentsP :: (FilePath -> Bool) -> FilePath+                   -> IO [(DirPath, [FileName])]+findFileInParentsP p dir =+    getFilesP p `zipMapM` parents dir++-- | @getFilesP p dir@. Find all __files__ satisfying @p@ in @.cabal@ in @dir@.+getFilesP :: (FilePath -> Bool) -> DirPath -> IO [FileName]+getFilesP p dir = filterM p' =<< getDirectoryContents dir+ where+   p' fn = do+     (p fn && ) <$> doesFileExist (dir </> fn)++findCabalSandboxDir :: FilePath -> IO (Maybe FilePath)+findCabalSandboxDir dir = do+  dss <- findFileInParentsP isSandboxConfig dir+  return $ case find (not . null . snd) $ dss of+             Just (sbDir, _:_) -> Just sbDir+             _ -> Nothing++ where+   isSandboxConfig = (==sandboxConfigFile)+ zipMapM :: Monad m => (a -> m c) -> [a] -> m [(a,c)]-zipMapM f as = mapM (\a -> liftM (a,) $ f a) as+zipMapM f as = mapM (\a -> liftM ((,) a) $ f a) as  -- | @parents dir@. Returns all parent directories of @dir@ including @dir@. --@@ -86,31 +178,48 @@  ---------------------------------------------------------------- --- | Get path to sandbox config file-getSandboxDb :: FilePath -- ^ Path to the cabal package root directory-                         -- (containing the @cabal.sandbox.config@ file)-             -> IO (Maybe FilePath)-getSandboxDb d = do-  mConf <- traverse readFile =<< U.mightExist (d </> "cabal.sandbox.config")-  return $ extractSandboxDbDir =<< mConf---- | Extract the sandbox package db directory from the cabal.sandbox.config file.---   Exception is thrown if the sandbox config file is broken.-extractSandboxDbDir :: String -> Maybe FilePath-extractSandboxDbDir conf = extractValue <$> parse conf-  where-    key = "package-db:"-    keyLen = length key--    parse = listToMaybe . filter (key `isPrefixOf`) . lines-    extractValue = U.dropWhileEnd isSpace . dropWhile isSpace . drop keyLen- setupConfigFile :: Cradle -> FilePath setupConfigFile crdl = cradleRootDir crdl </> setupConfigPath +sandboxConfigFile :: FilePath+sandboxConfigFile = "cabal.sandbox.config"+ -- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@ setupConfigPath :: FilePath-setupConfigPath = localBuildInfoFile defaultDistPref+setupConfigPath = "dist/setup-config" -- localBuildInfoFile defaultDistPref +macrosHeaderPath :: FilePath+macrosHeaderPath = "dist/build/autogen/cabal_macros.h"++ghcSandboxPkgDbDir :: String -> String+ghcSandboxPkgDbDir buildPlatf = do+    buildPlatf ++ "-ghc-" ++ cProjectVersion ++ "-packages.conf.d"+ packageCache :: String packageCache = "package.cache"++-- | Filename of the symbol table cache file.+symbolCache :: Cradle -> FilePath+symbolCache crdl = cradleTempDir crdl </> symbolCacheFile++symbolCacheFile :: String+symbolCacheFile = "ghc-mod.symbol-cache"++resolvedComponentsCacheFile :: String+resolvedComponentsCacheFile = setupConfigPath <.> "ghc-mod.resolved-components"++cabalHelperCacheFile :: String+cabalHelperCacheFile = setupConfigPath <.> "ghc-mod.cabal-components"++mergedPkgOptsCacheFile :: String+mergedPkgOptsCacheFile = setupConfigPath <.> "ghc-mod.package-options"++pkgDbStackCacheFile :: String+pkgDbStackCacheFile = setupConfigPath <.> "ghc-mod.package-db-stack"++-- | @findCustomPackageDbFile dir@. Searches for a @.ghc-mod.cradle@ file in @dir@.+-- If it exists in the given directory it is returned otherwise @findCradleFile@ returns @Nothing@+findCustomPackageDbFile :: FilePath -> IO (Maybe FilePath)+findCustomPackageDbFile directory = do+    let path = directory </> "ghc-mod.package-db-stack"+    mightExist path

@@ -5,22 +5,23 @@ import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Utils -import Control.Applicative ((<$>))+import Control.Applicative+import Prelude  -- | Obtaining the package name and the doc path of a module. pkgDoc :: IOish m => String -> GhcModT m String pkgDoc mdl = do-    c <- cradle-    pkg <- trim <$> readProcess' "ghc-pkg" (toModuleOpts c)+    pkgDbStack <- getPackageDbStack+    pkg <- liftIO $ trim <$> readProcess "ghc-pkg" (toModuleOpts pkgDbStack) ""     if pkg == "" then         return "\n"       else do-        htmlpath <- readProcess' "ghc-pkg" (toDocDirOpts pkg c)+        htmlpath <- liftIO $ readProcess "ghc-pkg" (toDocDirOpts pkg pkgDbStack) ""         let ret = pkg ++ " " ++ drop 14 htmlpath         return ret   where-    toModuleOpts c = ["find-module", mdl, "--simple-output"]-                   ++ ghcPkgDbStackOpts (cradlePkgDbStack c)-    toDocDirOpts pkg c = ["field", pkg, "haddock-html"]-                       ++ ghcPkgDbStackOpts (cradlePkgDbStack c)+    toModuleOpts dbs = ["find-module", mdl, "--simple-output"]+                   ++ ghcPkgDbStackOpts dbs+    toDocDirOpts pkg dbs = ["field", pkg, "haddock-html"]+                       ++ ghcPkgDbStackOpts dbs     trim = takeWhile (`notElem` " \n")

@@ -0,0 +1,69 @@+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.++module Language.Haskell.GhcMod.Pretty where++import Control.Arrow hiding ((<+>))+import Data.Char+import Data.List+import Distribution.Helper+import Text.PrettyPrint++import Language.Haskell.GhcMod.Types++docStyle :: Style+docStyle = style { ribbonsPerLine = 1.2 }++gmRenderDoc :: Doc -> String+gmRenderDoc = renderStyle docStyle++gmComponentNameDoc :: ChComponentName -> Doc+gmComponentNameDoc ChSetupHsName   = text $ "Setup.hs"+gmComponentNameDoc ChLibName       = text $ "library"+gmComponentNameDoc (ChExeName n)   = text $ "exe:" ++ n+gmComponentNameDoc (ChTestName n)  = text $ "test:" ++ n+gmComponentNameDoc (ChBenchName n) = text $ "bench:" ++ n++gmLogLevelDoc :: GmLogLevel -> Doc+gmLogLevelDoc GmSilent    = error "GmSilent MUST not be used for log messages"+gmLogLevelDoc GmPanic     = text "PANIC"+gmLogLevelDoc GmException = text "EXCEPTION"+gmLogLevelDoc GmError     = text "ERROR"+gmLogLevelDoc GmWarning   = text "Warning"+gmLogLevelDoc GmInfo      = text "info"+gmLogLevelDoc GmDebug     = text "DEBUG"+gmLogLevelDoc GmVomit     = text "VOMIT"++infixl 6 <+>:+(<+>:) :: Doc -> Doc -> Doc+a <+>: b = (a <> colon) <+> b++fnDoc :: FilePath -> Doc+fnDoc = doubleQuotes . text++showDoc :: Show a => a -> Doc+showDoc = text . show++warnDoc :: Doc -> Doc+warnDoc d = text "Warning" <+>: d++strDoc :: String -> Doc+strDoc str = doc (dropWhileEnd isSpace str)+ where+   doc :: String -> Doc+   doc = lines+         >>> map (words >>> map text >>> fsep)+         >>> \l -> case l of (x:xs) -> hang x 4 (vcat xs); [] -> empty

@@ -3,7 +3,7 @@  module Language.Haskell.GhcMod.SrcUtils where -import Control.Applicative ((<$>))+import Control.Applicative import CoreUtils (exprType) import Data.Generics import Data.Maybe (fromMaybe)@@ -13,15 +13,13 @@ import GHC.SYB.Utils (Stage(..), everythingStaged) import GhcMonad import qualified Language.Haskell.Exts.Annotated as HE-import Language.Haskell.GhcMod.Doc (showOneLine, getStyle)-import Language.Haskell.GhcMod.DynFlags-import Language.Haskell.GhcMod.Gap (HasType(..), setWarnTypedHoles, setDeferTypeErrors)+import Language.Haskell.GhcMod.Doc+import Language.Haskell.GhcMod.Gap import qualified Language.Haskell.GhcMod.Gap as Gap-import Language.Haskell.GhcMod.Monad (IOish, GhcModT)-import Language.Haskell.GhcMod.Target (setTargetFiles) import OccName (OccName) import Outputable (PprStyle) import TcHsSyn (hsPatType)+import Prelude  ---------------------------------------------------------------- @@ -82,22 +80,6 @@  pretty :: DynFlags -> PprStyle -> Type -> String pretty dflag style = showOneLine dflag style . Gap.typeForUser--------------------------------------------------------------------inModuleContext :: IOish m-                => FilePath-                -> (DynFlags -> PprStyle -> GhcModT m a)-                -> GhcModT m a-inModuleContext file action =-    withDynFlags (setWarnTypedHoles . setDeferTypeErrors . setNoWarningFlags) $ do-    setTargetFiles [file]-    Gap.withContext $ do-        dflag <- G.getSessionDynFlags-        style <- getStyle-        action dflag style------------------------------------------------------------------  showName :: DynFlags -> PprStyle -> G.Name -> String showName dflag style name = showOneLine dflag style $ Gap.nameForUser name

@@ -1,60 +1,486 @@-{-# LANGUAGE CPP #-}-module Language.Haskell.GhcMod.Target (-    setTargetFiles-  ) where+-- ghc-mod: Making Haskell development *more* fun+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as published by+-- the Free Software Foundation, either version 3 of the License, or+-- (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program.  If not, see <http://www.gnu.org/licenses/>. -import Control.Applicative ((<$>))-import Control.Monad (forM, void, (>=>))-import DynFlags (ExtensionFlag(..), xopt)-import GHC (LoadHowMuch(..))-import qualified GHC as G+{-# LANGUAGE CPP, ViewPatterns, NamedFieldPuns, RankNTypes #-}+module Language.Haskell.GhcMod.Target where++import Control.Arrow+import Control.Applicative+import Control.Category ((.))+import Control.Monad.Reader (runReaderT)+import GHC+import GHC.Paths (libdir)+import StaticFlags+import SysTools+import DynFlags+import HscMain+import HscTypes+ import Language.Haskell.GhcMod.DynFlags-import Language.Haskell.GhcMod.Monad+import Language.Haskell.GhcMod.Monad.Types+import Language.Haskell.GhcMod.CabalHelper+import Language.Haskell.GhcMod.HomeModuleGraph+import Language.Haskell.GhcMod.PathsAndFiles+import Language.Haskell.GhcMod.GhcPkg+import Language.Haskell.GhcMod.Error+import Language.Haskell.GhcMod.Logging+import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.Utils as U ++import Data.Maybe+import Data.Monoid as Monoid+import Data.Either+import Data.Foldable as Foldable (foldrM)+import qualified Data.Foldable as Foldable+import Data.Traversable hiding (mapM, forM)+import Data.IORef+import Data.List+import Data.Map (Map)+import qualified Data.Map  as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Distribution.Helper+import Prelude hiding ((.))++import System.Directory+import System.FilePath++withLightHscEnv :: forall m a. IOish m+    => [GHCOption] -> (HscEnv -> m a) -> m a+withLightHscEnv opts action = gbracket initEnv teardownEnv action+ where+   teardownEnv :: HscEnv -> m ()+   teardownEnv env = liftIO $ do+       let dflags = hsc_dflags env+       cleanTempFiles dflags+       cleanTempDirs dflags++   initEnv :: m HscEnv+   initEnv = liftIO $ do+     initStaticOpts+     settings <- initSysTools (Just libdir)+     dflags  <- initDynFlags (defaultDynFlags settings)+     env <- newHscEnv dflags+     dflags' <- runLightGhc env $ do+         -- HomeModuleGraph and probably all other clients get into all sorts of+         -- trouble if the package state isn't initialized here+         _ <- setSessionDynFlags =<< addCmdOpts opts =<< getSessionDynFlags+         getSessionDynFlags+     newHscEnv dflags'++runLightGhc :: HscEnv -> LightGhc a -> IO a+runLightGhc env action = do+  renv <- newIORef env+  flip runReaderT renv $ unLightGhc action++runGmPkgGhc :: (IOish m, GmEnv m, GmState m, GmLog m) => LightGhc a -> m a+runGmPkgGhc action = do+    pkgOpts <- packageGhcOptions+    withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action++initSession :: IOish m+            => [GHCOption] -> (DynFlags -> Ghc DynFlags) -> GhcModT m ()+initSession opts mdf = do+   s <- gmsGet+   case gmGhcSession s of+     Just GmGhcSession {..} -> when (gmgsOptions /= opts) $ putNewSession s+     Nothing -> putNewSession s++ where+   putNewSession s = do+     rghc <- (liftIO . newIORef =<< newSession =<< cradle)+     gmsPut s { gmGhcSession = Just $ GmGhcSession opts rghc }++   newSession Cradle { cradleTempDir } = liftIO $ do+     runGhc (Just libdir) $ do+       let setDf df = setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df)+       _ <- setSessionDynFlags =<< setDf =<< getSessionDynFlags+       getSession++-- | Drop the currently active GHC session, the next that requires a GHC session+-- will initialize a new one.+dropSession :: IOish m => GhcModT m ()+dropSession = do+  s <- gmsGet+  case gmGhcSession s of+    Just (GmGhcSession _opts ref) -> do+      -- TODO: This is still not enough, there seem to still be references to+      -- GHC's state around afterwards.+      liftIO $ writeIORef ref (error "HscEnv: session was dropped")+      -- Not available on ghc<7.8; didn't really help anyways+      -- liftIO $ setUnsafeGlobalDynFlags (error "DynFlags: session was dropped")+      gmsPut s { gmGhcSession = Nothing }++    Nothing -> return ()+++runGmlT :: IOish m => [Either FilePath ModuleName] -> GmlT m a -> GhcModT m a+runGmlT fns action = runGmlT' fns return action++runGmlT' :: IOish m+              => [Either FilePath ModuleName]+              -> (DynFlags -> Ghc DynFlags)+              -> GmlT m a+              -> GhcModT m a+runGmlT' fns mdf action = runGmlTWith fns mdf id action++runGmlTWith :: IOish m+                 => [Either FilePath ModuleName]+                 -> (DynFlags -> Ghc DynFlags)+                 -> (GmlT m a -> GmlT m b)+                 -> GmlT m a+                 -> GhcModT m b+runGmlTWith efnmns' mdf wrapper action = do+    crdl <- cradle+    Options { ghcUserOptions } <- options++    let (fns, mns) = partitionEithers efnmns'+        ccfns = map (cradleCurrentDir crdl </>) fns+    cfns <- liftIO $ mapM canonicalizePath ccfns+    let serfnmn = Set.fromList $ map Right mns ++ map Left cfns+    opts <- targetGhcOptions crdl serfnmn+    let opts' = opts ++ ["-O0"] ++ ghcUserOptions++    gmVomit+      "session-ghc-options"+      (text "Initializing GHC session with following options")+      (intercalate " " $ map (("\""++) . (++"\"")) opts')++    initSession opts' $+        setModeSimple >>> setEmptyLogger >>> mdf++    let rfns = map (makeRelative $ cradleRootDir crdl) cfns++    unGmlT $ wrapper $ do+      loadTargets (map moduleNameString mns ++ rfns)+      action++targetGhcOptions :: forall m. IOish m+                  => Cradle+                  -> Set (Either FilePath ModuleName)+                  -> GhcModT m [GHCOption]+targetGhcOptions crdl sefnmn = do+    when (Set.null sefnmn) $ error "targetGhcOptions: no targets given"++    case cradleProjectType crdl of+      CabalProject -> cabalOpts crdl+      _ -> sandboxOpts crdl+ where+   zipMap f l = l `zip` (f `map` l)++   cabalOpts :: Cradle -> GhcModT m [String]+   cabalOpts Cradle{..} = do+       mcs <- cabalResolvedComponents++       let mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn+           candidates = findCandidates $ map snd mdlcs++       let noCandidates = Set.null candidates+           noModuleHasAnyAssignment = all (Set.null . snd) mdlcs++       if noCandidates && noModuleHasAnyAssignment+          then do+            -- First component should be ChLibName, if no lib will take lexically first exe.+            let cns = filter (/= ChSetupHsName) $ Map.keys mcs++            gmLog GmWarning "" $ strDoc $ "Could not find a component assignment, falling back to picking library component in cabal file."+            return $ gmcGhcOpts $ fromJust $ Map.lookup (head cns) mcs+          else do+            when noCandidates $+              throwError $ GMECabalCompAssignment mdlcs++            let cn = pickComponent candidates+            return $ gmcGhcOpts $ fromJust $ Map.lookup cn mcs++resolvedComponentsCache :: IOish m => Cached (GhcModT m) GhcModState+    [GmComponent 'GMCRaw (Set.Set ModulePath)]+    (Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath)))+resolvedComponentsCache = Cached {+    cacheLens = Just (lGmcResolvedComponents . lGmCaches),+    cacheFile  = resolvedComponentsCacheFile,+    cachedAction = \tcfs comps ma -> do+        Cradle {..} <- cradle+        let iifsM = invalidatingInputFiles tcfs+            mums :: Maybe [Either FilePath ModuleName]+            mums =+              case iifsM of+                Nothing -> Nothing+                Just iifs ->+                  let+                      filterOutSetupCfg =+                          filter (/= cradleRootDir </> setupConfigPath)+                      changedFiles = filterOutSetupCfg iifs+                  in if null changedFiles+                       then Nothing+                       else Just $ map Left changedFiles+            setupChanged = maybe False+                                 (elem $ cradleRootDir </> setupConfigPath)+                                 iifsM+        case (setupChanged, ma) of+          (False, Just mcs) -> gmsGet >>= \s -> gmsPut s { gmComponents = mcs }+          _ -> return ()++        let mdesc (Left f) = "file:" ++ f+            mdesc (Right mn) = "module:" ++ moduleNameString mn++            changed = map (text . mdesc) $ Foldable.concat mums+            changedDoc | [] <- changed = text "none"+                       | otherwise = sep changed++        gmLog GmDebug "resolvedComponentsCache" $+              text "files changed" <+>: changedDoc++        mcs <- resolveGmComponents mums comps+        return (setupConfigPath:flatten mcs , mcs)+ }++ where+   flatten :: Map.Map ChComponentName (GmComponent t (Set.Set ModulePath))+           -> [FilePath]+   flatten = Map.elems+      >>> map (gmcHomeModuleGraph >>> gmgGraph+               >>> Map.elems+               >>> map (Set.map mpPath)+               >>> Set.unions+              )+      >>> Set.unions+      >>> Set.toList++moduleComponents :: Map ChComponentName (GmComponent t (Set ModulePath))+                 -> Either FilePath ModuleName+                 -> Set ChComponentName+moduleComponents m efnmn =+    foldr' Set.empty m $ \c s ->+        let+            memb =+              case efnmn of+                Left fn  -> fn `Set.member` Set.map mpPath (smp c)+                Right mn -> mn `Set.member` Set.map mpModule (smp c)+        in if memb+           then Set.insert (gmcName c) s+           else s+ where+   smp c = Map.keysSet $ gmgGraph $ gmcHomeModuleGraph c++   foldr' b as f = Map.foldr f b as+++findCandidates :: [Set ChComponentName] -> Set ChComponentName+findCandidates [] = Set.empty+findCandidates scns = foldl1 Set.intersection scns++pickComponent :: Set ChComponentName -> ChComponentName+pickComponent scn = Set.findMin scn++packageGhcOptions :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m)+                  => m [GHCOption]+packageGhcOptions = do+    crdl <- cradle+    case cradleProjectType crdl of+      CabalProject -> getGhcMergedPkgOptions+      _ -> sandboxOpts crdl++-- also works for plain projects!+sandboxOpts :: MonadIO m => Cradle -> m [String]+sandboxOpts crdl = do+    pkgDbStack <- liftIO $ getSandboxPackageDbStack $ cradleRootDir crdl+    let pkgOpts = ghcDbStackOpts pkgDbStack+    return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts ++ ["-Wall"]+  where+    (wdir, rdir) = (cradleCurrentDir crdl, cradleRootDir crdl)++    getSandboxPackageDbStack :: FilePath+                      -- ^ Project Directory (where the cabal.sandbox.config+                      -- file would be if it exists)+                      -> IO [GhcPkgDb]+    getSandboxPackageDbStack cdir =+        ([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb cdir++resolveGmComponent :: (IOish m, GmLog m, GmEnv m)+    => Maybe [CompilationUnit] -- ^ Updated modules+    -> GmComponent 'GMCRaw (Set ModulePath)+    -> m (GmComponent 'GMCResolved (Set ModulePath))+resolveGmComponent mums c@GmComponent {..} = do+  withLightHscEnv ghcOpts $ \env -> do+    let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs+    let mg = gmcHomeModuleGraph+    let simp = gmcEntrypoints+    sump <- case mums of+        Nothing -> return simp+        Just ums ->+            Set.fromList . catMaybes <$>+               mapM (resolveModule env srcDirs) ums++    mg' <- canonicalizeModuleGraph =<< updateHomeModuleGraph env mg simp sump++    return $ c { gmcEntrypoints = simp, gmcHomeModuleGraph = mg' }++ where ghcOpts = concat [+           gmcGhcSrcOpts,+           gmcGhcLangOpts,+           [ "-optP-include", "-optP" ++ macrosHeaderPath ]+        ]++resolveEntrypoint :: (IOish m, GmEnv m, GmLog m)+    => Cradle+    -> GmComponent 'GMCRaw ChEntrypoint+    -> m (GmComponent 'GMCRaw (Set ModulePath))+resolveEntrypoint Cradle {..} c@GmComponent {..} = do+    withLightHscEnv gmcGhcSrcOpts $ \env -> do+      let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs+      eps <- liftIO $ resolveChEntrypoints cradleRootDir gmcEntrypoints+      rms <- resolveModule env srcDirs `mapM` eps+      return c { gmcEntrypoints = Set.fromList $ catMaybes rms }++-- TODO: remember that he file from `main-is:` is always module `Main` and let+-- ghc do the warning about it. Right now we run that module through+-- resolveModule like any other+resolveChEntrypoints :: FilePath -> ChEntrypoint -> IO [CompilationUnit]+resolveChEntrypoints _ (ChLibEntrypoint em om) =+    return $ map (Right . chModToMod) (em ++ om)++resolveChEntrypoints _ (ChExeEntrypoint main om) =+    return $ [Left main] ++ map (Right . chModToMod) om++resolveChEntrypoints srcDir ChSetupEntrypoint = do+  shs <- doesFileExist (srcDir </> "Setup.hs")+  slhs <- doesFileExist (srcDir </> "Setup.lhs")+  return $ case (shs, slhs) of+    (True, _) -> [Left "Setup.hs"]+    (_, True) -> [Left "Setup.lhs"]+    (False, False) -> []++chModToMod :: ChModuleName -> ModuleName+chModToMod (ChModuleName mn) = mkModuleName mn++resolveModule :: (MonadIO m, GmEnv m, GmLog m) =>+  HscEnv -> [FilePath] -> CompilationUnit -> m (Maybe ModulePath)+resolveModule env _srcDirs (Right mn) =+    liftIO $ traverse canonicalizeModulePath =<< findModulePath env mn+resolveModule env srcDirs (Left fn') = do+    mfn <-  liftIO $ findFile' srcDirs fn'+    case mfn of+      Nothing -> return Nothing+      Just fn'' -> do+          fn <-  liftIO $ canonicalizePath fn''+          emn <-  liftIO $ fileModuleName env fn+          case emn of+              Left errs -> do+                gmLog GmWarning ("resolveModule " ++ show fn) $+                  Monoid.mempty $+$ (vcat $ map text errs)+                return Nothing -- TODO: should expose these errors otherwise+                               -- modules with preprocessor/parse errors are+                               -- going to be missing+              Right mmn -> return $ Just $+                  case mmn of+                    Nothing -> mkMainModulePath fn+                    Just mn -> ModulePath mn fn+ where+   -- needed for ghc 7.4+   findFile' dirs file =+       getFirst . mconcat <$> mapM (fmap First . mightExist . (</>file)) dirs++   -- fileModuleName fn (dir:dirs)+   --     | makeRelative dir fn /= fn++type CompilationUnit = Either FilePath ModuleName++resolveGmComponents :: (IOish m, GmState m, GmLog m, GmEnv m)+    => Maybe [CompilationUnit]+        -- ^ Updated modules+    -> [GmComponent 'GMCRaw (Set ModulePath)]+    -> m (Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath)))+resolveGmComponents mumns cs = do+    s <- gmsGet+    m' <- foldrM' (gmComponents s) cs $ \c m -> do+        case Map.lookup (gmcName c) m of+          Nothing -> insertUpdated m c+          Just c' -> if same gmcRawEntrypoints c c' && same gmcGhcSrcOpts c c'+                       then return m+                       else insertUpdated m c+    gmsPut s { gmComponents = m' }+    return m'++ where+   foldrM' b fa f = foldrM f b fa+   insertUpdated m c = do+     rc <- resolveGmComponent mumns c+     return $ Map.insert (gmcName rc) rc m++   same :: Eq b+        => (forall t a. GmComponent t a -> b)+        -> GmComponent u c -> GmComponent v d -> Bool+   same f a b = (f a) == (f b)+ -- | Set the files as targets and load them.-setTargetFiles :: IOish m => [FilePath] -> GhcModT m ()-setTargetFiles files = do-    targets <- forM files $ \file -> G.guessTarget file Nothing-    G.setTargets targets+loadTargets :: IOish m => [String] -> GmlT m ()+loadTargets filesOrModules = do+    gmLog GmDebug "loadTargets" $+          text "Loading" <+>: fsep (map text filesOrModules)++    targets <- forM filesOrModules (flip guessTarget Nothing)+    setTargets targets+     mode <- getCompilerMode-    if mode == Intelligent then-        loadTargets Intelligent+    if mode == Intelligent+      then loadTargets' Intelligent       else do-        mdls <- G.depanal [] False+        mdls <- depanal [] False         let fallback = needsFallback mdls         if fallback then do             resetTargets targets             setIntelligent-            loadTargets Intelligent+            gmLog GmInfo "loadTargets" $+                text "Target needs interpeter, switching to LinkInMemory/HscInterpreted. Perfectly normal if anything is using TemplateHaskell, QuasiQuotes or PatternSynonyms."+            loadTargets' Intelligent           else-            loadTargets Simple+            loadTargets' Simple   where-    loadTargets Simple = do-        -- Reporting error A and error B-        void $ G.load LoadAllTargets-        mss <- filter (\x -> G.ms_hspp_file x `elem` files) <$> G.getModuleGraph-        -- Reporting error B and error C-        mapM_ (G.parseModule >=> G.typecheckModule >=> G.desugarModule) mss-        -- Error B duplicates. But we cannot ignore both error reportings,-        -- sigh. So, the logger makes log messages unique by itself.-    loadTargets Intelligent = do-        df <- G.getSessionDynFlags-        void $ G.setSessionDynFlags (setModeIntelligent df)-        void $ G.load LoadAllTargets+    loadTargets' Simple = do+        void $ load LoadAllTargets+        mapM_ (parseModule >=> typecheckModule >=> desugarModule) =<< getModuleGraph++    loadTargets' Intelligent = do+        df <- getSessionDynFlags+        void $ setSessionDynFlags (setModeIntelligent df)+        void $ load LoadAllTargets+     resetTargets targets = do-        G.setTargets []-        void $ G.load LoadAllTargets-        G.setTargets targets+        setTargets []+        void $ load LoadAllTargets+        setTargets targets+     setIntelligent = do-        newdf <- setModeIntelligent <$> G.getSessionDynFlags-        void $ G.setSessionDynFlags newdf+        newdf <- setModeIntelligent <$> getSessionDynFlags+        void $ setSessionDynFlags newdf         setCompilerMode Intelligent -needsFallback :: G.ModuleGraph -> Bool+needsFallback :: ModuleGraph -> Bool needsFallback = any $ \ms ->-                let df = G.ms_hspp_opts ms in+                let df = ms_hspp_opts ms in                    Opt_TemplateHaskell `xopt` df                 || Opt_QuasiQuotes     `xopt` df #if __GLASGOW_HASKELL__ >= 708                 || (Opt_PatternSynonyms `xopt` df) #endif++cabalResolvedComponents :: (IOish m) =>+   GhcModT m (Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath)))+cabalResolvedComponents = do+    crdl@(Cradle{..}) <- cradle+    comps <- mapM (resolveEntrypoint crdl) =<< getComponents+    cached cradleRootDir resolvedComponentsCache comps

@@ -1,13 +1,46 @@-module Language.Haskell.GhcMod.Types where+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric,+  StandaloneDeriving, DefaultSignatures, FlexibleInstances, TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}+module Language.Haskell.GhcMod.Types (+    module Language.Haskell.GhcMod.Types+  , ModuleName+  , mkModuleName+  , moduleNameString+  ) where  import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Monad.Error (Error(..))+import qualified Control.Monad.IO.Class as MTL+import Control.Exception (Exception)+import Control.Applicative+import Control.Concurrent+import Control.Monad+import Data.Serialize+import Data.Version import Data.List (intercalate)-import qualified Data.Map as M+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Monoid+import Data.Maybe+import Data.Typeable (Typeable)+import Data.IORef+import Data.Label.Derive+import Distribution.Helper import Exception (ExceptionMonad)-import MonadUtils (MonadIO)-+#if __GLASGOW_HASKELL__ < 708+import qualified MonadUtils as GHC (MonadIO(..))+#endif+import GHC (ModuleName, moduleNameString, mkModuleName)+import HscTypes (HscEnv) import PackageConfig (PackageConfig)+import GHC.Generics+import Text.PrettyPrint (Doc)+import Prelude +import Language.Haskell.GhcMod.Caching.Types+ -- | A constraint alias (-XConstraintKinds) to make functions dealing with -- 'GhcModT' somewhat cleaner. --@@ -16,6 +49,18 @@ -- the exported API so users have the option to use a custom inner monad. type IOish m = (Functor m, MonadIO m, MonadBaseControl IO m, ExceptionMonad m) ++-- MonadUtils of GHC 7.6 or earlier defines its own MonadIO.+-- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class.+#if __GLASGOW_HASKELL__ < 708+type MonadIOC m = (GHC.MonadIO m, MTL.MonadIO m)+#else+type MonadIOC m = (MTL.MonadIO m)+#endif++class MonadIOC m => MonadIO m where+  liftIO :: IO a -> m a+ -- | Output style. data OutputStyle = LispStyle  -- ^ S expression style.                  | PlainStyle -- ^ Plain textstyle.@@ -28,8 +73,15 @@     outputStyle   :: OutputStyle   -- | Line separator string.   , lineSeparator :: LineSeparator+  -- | Stdout/err line multiplexing using prefix encoding. @fst@ is stdout,+  -- @snd@ is stderr prefix.+  , linePrefix :: Maybe (String, String)+  -- | Verbosity+  , logLevel      :: GmLogLevel   -- | @ghc@ program name.   , ghcProgram    :: FilePath+  -- | @ghc-pkg@ program name.+  , ghcPkgProgram :: FilePath   -- | @cabal@ program name.   , cabalProgram  :: FilePath     -- | GHC command line options set on the @ghc-mod@ command line@@ -43,44 +95,114 @@   , hlintOpts     :: [String]   } deriving (Show) - -- | A default 'Options'. defaultOptions :: Options defaultOptions = Options {-    outputStyle   = PlainStyle-  , hlintOpts     = []-  , ghcProgram    = "ghc"-  , cabalProgram  = "cabal"-  , ghcUserOptions= []-  , operators     = False-  , detailed      = False-  , qualified     = False-  , lineSeparator = LineSeparator "\0"+    outputStyle    = PlainStyle+  , lineSeparator  = LineSeparator "\0"+  , linePrefix     = Nothing+  , logLevel       = GmWarning+  , ghcProgram     = "ghc"+  , ghcPkgProgram  = "ghc-pkg"+  , cabalProgram   = "cabal"+  , ghcUserOptions = []+  , operators      = False+  , detailed       = False+  , qualified      = False+  , hlintOpts      = []   }  ---------------------------------------------------------------- +data ProjectType = CabalProject | SandboxProject | PlainProject+                 deriving (Eq, Show)+ -- | The environment where this library is used. data Cradle = Cradle {+    cradleProjectType:: ProjectType   -- | The directory where this library is executed.-    cradleCurrentDir :: FilePath+  , cradleCurrentDir :: FilePath   -- | The project root directory.   , cradleRootDir    :: FilePath   -- | Per-Project temporary directory   , cradleTempDir    :: FilePath   -- | The file name of the found cabal file.   , cradleCabalFile  :: Maybe FilePath-  -- | Package database stack-  , cradlePkgDbStack  :: [GhcPkgDb]   } deriving (Eq, Show) ++data GmStream = GmOut | GmErr+                deriving (Show)++data GmLineType = GmTerminated | GmPartial+                deriving (Show)++data GmLines a = GmLines GmLineType a+              deriving (Show, Functor)++unGmLine :: GmLines a -> a+unGmLine (GmLines _ s) = s++data GmOutput = GmOutputStdio+              | GmOutputChan (Chan (GmStream, GmLines String))++data GhcModEnv = GhcModEnv {+      gmOptions    :: Options+    , gmCradle     :: Cradle+    , gmOutput     :: GmOutput+    }++data GhcModLog = GhcModLog {+      gmLogLevel     :: Maybe GmLogLevel,+      gmLogVomitDump :: Last Bool,+      gmLogMessages  :: [(GmLogLevel, String, Doc)]+    } deriving (Show)++instance Monoid GhcModLog where+    mempty = GhcModLog (Just GmPanic) (Last Nothing) mempty+    GhcModLog ml vd ls `mappend` GhcModLog ml' vd' ls' =+        GhcModLog (ml' `mplus` ml) (vd `mappend` vd') (ls `mappend` ls')++data GmGhcSession = GmGhcSession {+      gmgsOptions :: ![GHCOption],+      gmgsSession :: !(IORef HscEnv)+    }++data GhcModCaches = GhcModCaches {+      gmcPackageDbStack   :: CacheContents ChCacheData [GhcPkgDb]+    , gmcMergedPkgOptions :: CacheContents ChCacheData [GHCOption]+    , gmcComponents       :: CacheContents ChCacheData [GmComponent 'GMCRaw ChEntrypoint]+    , gmcResolvedComponents :: CacheContents+          [GmComponent 'GMCRaw (Set.Set ModulePath)]+          (Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath)))+    }++data GhcModState = GhcModState {+      gmGhcSession   :: !(Maybe GmGhcSession)+    , gmComponents   :: !(Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath)))+    , gmCompilerMode :: !CompilerMode+    , gmCaches       :: !GhcModCaches+    }++data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read)++defaultGhcModState :: GhcModState+defaultGhcModState =+    GhcModState n Map.empty Simple (GhcModCaches n n n n)+ where n = Nothing+ ----------------------------------------------------------------  -- | GHC package database flags.-data GhcPkgDb = GlobalDb | UserDb | PackageDb String deriving (Eq, Show)+data GhcPkgDb = GlobalDb+              | UserDb+              | PackageDb String+                deriving (Eq, Show, Generic) +instance Serialize GhcPkgDb+ -- | A single GHC command line option.-type GHCOption  = String+type GHCOption = String  -- | An include directory for modules. type IncludeDir = FilePath@@ -89,44 +211,175 @@ type PackageBaseName = String  -- | A package version.-type PackageVersion  = String+type PackageVersion = String  -- | A package id.-type PackageId  = String+type PackageId = String  -- | A package's name, verson and id.-type Package    = (PackageBaseName, PackageVersion, PackageId)+type Package = (PackageBaseName, PackageVersion, PackageId)  pkgName :: Package -> PackageBaseName-pkgName (n,_,_) = n+pkgName (n, _, _) = n  pkgVer :: Package -> PackageVersion-pkgVer (_,v,_) = v+pkgVer (_, v, _) = v  pkgId :: Package -> PackageId-pkgId (_,_,i) = i+pkgId (_, _, i) = i  showPkg :: Package -> String-showPkg (n,v,_) = intercalate "-" [n,v]+showPkg (n, v, _) = intercalate "-" [n, v]  showPkgId :: Package -> String-showPkgId (n,v,i) = intercalate "-" [n,v,i]---- | Collection of packages-type PkgDb = (M.Map Package PackageConfig)+showPkgId (n, v, i) = intercalate "-" [n, v, i]  -- | Haskell expression.-type Expression = String+newtype Expression = Expression { getExpression :: String }+  deriving (Show, Eq, Ord)  -- | Module name.-type ModuleString = String+newtype ModuleString = ModuleString { getModuleString :: String }+  deriving (Show, Read, Eq, Ord) --- | A Module-type Module = [String]+data GmLogLevel =+    GmSilent+  | GmPanic+  | GmException+  | GmError+  | GmWarning+  | GmInfo+  | GmDebug+  | GmVomit+    deriving (Eq, Ord, Enum, Bounded, Show, Read) --- | Option information for GHC-data CompilerOptions = CompilerOptions {-    ghcOptions  :: [GHCOption]  -- ^ Command line options-  , includeDirs :: [IncludeDir] -- ^ Include directories for modules-  , depPackages :: [Package]    -- ^ Dependent package names-  } deriving (Eq, Show)+-- | Collection of packages+type PkgDb = (Map Package PackageConfig)++data GmModuleGraph = GmModuleGraph {+    gmgGraph :: Map ModulePath (Set ModulePath)+  } deriving (Eq, Ord, Show, Read, Generic, Typeable)++instance Serialize GmModuleGraph where+  put GmModuleGraph {..} = put (mpim, graph)+    where+      mpim :: Map ModulePath Integer+      mpim = Map.fromList $ Map.keys gmgGraph `zip` [0..]+      graph :: Map Integer (Set Integer)+      graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph+      mpToInt :: ModulePath -> Integer+      mpToInt mp = fromJust $ Map.lookup mp mpim++  get = do+    (mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get+    let impm = swapMap mpim+        intToMp i = fromJust $ Map.lookup i impm+        mpGraph :: Map ModulePath (Set ModulePath)+        mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph+    return $ GmModuleGraph mpGraph+    where+      swapMap :: (Ord k, Ord v) => Map k v -> Map v k+      swapMap = Map.fromList . map (\(x, y) -> (y, x)) . Map.toList++instance Monoid GmModuleGraph where+  mempty  = GmModuleGraph mempty+  mappend (GmModuleGraph a) (GmModuleGraph a') =+    GmModuleGraph (Map.unionWith Set.union a a')++data GmComponentType = GMCRaw+                     | GMCResolved+data GmComponent (t :: GmComponentType) eps = GmComponent {+    gmcHomeModuleGraph :: GmModuleGraph+  , gmcName            :: ChComponentName+  , gmcGhcOpts         :: [GHCOption]+  , gmcGhcPkgOpts      :: [GHCOption]+  , gmcGhcSrcOpts      :: [GHCOption]+  , gmcGhcLangOpts     :: [GHCOption]+  , gmcRawEntrypoints  :: ChEntrypoint+  , gmcEntrypoints     :: eps+  , gmcSourceDirs      :: [FilePath]+  } deriving (Eq, Ord, Show, Read, Generic, Functor)++instance Serialize eps => Serialize (GmComponent t eps)++data ModulePath = ModulePath { mpModule :: ModuleName, mpPath :: FilePath }+  deriving (Eq, Ord, Show, Read, Generic, Typeable)+instance Serialize ModulePath++instance Serialize ModuleName where+  get = mkModuleName <$> get+  put mn = put (moduleNameString mn)++instance Show ModuleName where+  show mn = "ModuleName " ++ show (moduleNameString mn)++instance Read ModuleName where+  readsPrec d =+    readParen+      (d > app_prec)+      (\r' -> [ (mkModuleName m, t)+              | ("ModuleName", s) <- lex r'+              , (m, t)            <- readsPrec (app_prec + 1) s+              ])+    where+      app_prec = 10++data GhcModError+  = GMENoMsg+  -- ^ Unknown error++  | GMEString String+  -- ^ Some Error with a message. These are produced mostly by+  -- 'fail' calls on GhcModT.++  | GMECabalConfigure GhcModError+  -- ^ Configuring a cabal project failed.++  | GMECabalFlags GhcModError+  -- ^ Retrieval of the cabal configuration flags failed.++  | GMECabalComponent ChComponentName+  -- ^ Cabal component could not be found++  | GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)]+  -- ^ Could not find a consistent component assignment for modules++  | GMEProcess String [String] (Either (String, String, Int) GhcModError)+  -- ^ Launching an operating system process failed. Fields in+  -- order: command, arguments, (stdout, stderr, exitcode)++  | GMENoCabalFile+  -- ^ No cabal file found.++  | GMETooManyCabalFiles [FilePath]+  -- ^ Too many cabal files found.++  | GMECabalStateFile GMConfigStateFileError+    -- ^ Reading Cabal's state configuration file falied somehow.+    deriving (Eq,Show,Typeable)++instance Error GhcModError where+  noMsg  = GMENoMsg+  strMsg = GMEString++instance Exception GhcModError++data GMConfigStateFileError+  = GMConfigStateFileNoHeader+  | GMConfigStateFileBadHeader+  | GMConfigStateFileNoParse+  | GMConfigStateFileMissing+--  | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo)+  deriving (Eq, Show, Read, Typeable)+++deriving instance Generic Version+instance Serialize Version++instance Serialize Programs+instance Serialize ChModuleName+instance Serialize ChComponentName+instance Serialize ChEntrypoint++mkLabel ''GhcModCaches+mkLabel ''GhcModState