Merge branch 'master' into release

.gitignore

@@ -7,8 +7,14 @@ package.cache
 cabal.sandbox.config
 # Mac OS generates
 # .DS_Store
+*.o
+*.dyn_o
+*.hi
+*.dyn_hi
 
 # Where do these files come from?  They're not readable.
 # For instance, .#Help.page
 # .#*
 cabal-dev
+/TAGS
+/tags

.travis.yml

@@ -4,11 +4,36 @@ ghc:
   - 7.6
   - 7.8
 
+sudo: false
+
+addons:
+  apt:
+    packages:
+    - zlib1g-dev
+
+cache:
+  apt: true
+  directories:
+  - ~/.cabal
+  - ~/.ghc
+
+before_cache:
+  - rm -f $HOME/.cabal/logs $HOME/.cabal/packages/*/build-reports.log
+
 install:
   - cabal update
-  - cabal install happy --constraint 'transformers <= 0.3.0.0'
+#  - ( $CABAL122 && cabal install cabal-install --constraint "Cabal >= 1.22" && ghc-pkg unregister Cabal ) || true
+  - echo $PATH
+  - which cabal
+  - if [ -n "$(cabal --version | grep 'Cabal library' | awk '{ print $3 }' | tail -n1 | sed -n '/^1.18/p')" ]; then cabal install cabal-install --constraint "Cabal == 1.18.* && > 1.18.0"; fi
+  - cabal install happy
   - happy --version
+#  - ls -lR ~/.ghc
+#  - ls -lR ~/.cabal
   - cabal install -j --only-dependencies --enable-tests
+  - git clone --depth=1 https://github.com/DanielG/cabal-helper.git
+  - cabal install cabal-helper/
+
 
 script:
   - touch ChangeLog # Create ChangeLog if we're not on the release branch
@@ -21,6 +46,7 @@ script:
   - if [ -n "$(ghc --version | awk '{ print $8 }' | sed -n '/^7.8/p')" ]; then export WERROR="--ghc-option=-Werror"; fi
   - cabal configure --enable-tests $WERROR
   - cabal build
+  - export ghc_mod_datadir=$PWD
   - cabal test
 
 matrix:

COPYING.AGPL3

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

COPYING.BSD3

@@ -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.

LICENSE

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

Language/Haskell/GhcMod.hs

@@ -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 @@ module Language.Haskell.GhcMod (
   -- * Monad utilities
   , runGhcModT
   , withOptions
+  , dropSession
   -- * 'GhcMod' utilities
   , boot
   , browse
   , check
   , checkSyntax
   , debugInfo
+  , componentInfo
   , expandTemplate
   , info
   , lint
@@ -47,6 +56,13 @@ module Language.Haskell.GhcMod (
   -- * SymbolDb
   , loadSymbolDb
   , isOutdated
+  -- * Output
+  , gmPutStr
+  , gmErrStr
+  , gmPutStrLn
+  , gmErrStrLn
+  , gmUnsafePutStrLn
+  , gmUnsafeErrStrLn
   ) where
 
 import Language.Haskell.GhcMod.Boot
@@ -61,7 +77,10 @@ import Language.Haskell.GhcMod.Flag
 import Language.Haskell.GhcMod.Info
 import Language.Haskell.GhcMod.Lang
 import Language.Haskell.GhcMod.Lint
-import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.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

Language/Haskell/GhcMod/Boot.hs

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

Language/Haskell/GhcMod/Browse.hs

@@ -2,54 +2,57 @@ module Language.Haskell.GhcMod.Browse (
     browse
   ) where
 
-import Control.Applicative ((<$>))
+import Control.Applicative
 import Control.Exception (SomeException(..))
-import Data.Char (isAlpha)
+import Data.Char
-import Data.List (sort)
+import Data.List
-import Data.Maybe (catMaybes)
+import Data.Maybe
-import Exception (ghandle)
+import FastString
-import FastString (mkFastString)
+import GHC
-import GHC (GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon)
 import qualified GHC as G
 import Language.Haskell.GhcMod.Convert
 import Language.Haskell.GhcMod.Doc (showPage, styleUnqualified)
-import Language.Haskell.GhcMod.Gap
+import Language.Haskell.GhcMod.Gap as Gap
-import Language.Haskell.GhcMod.Monad (GhcModT, options)
+import Language.Haskell.GhcMod.Monad
-import Language.Haskell.GhcMod.Target (setTargetFiles)
 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
+browse :: forall m. IOish m
-       => ModuleString -- ^ A module name. (e.g. \"Data.List\")
+       => 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 @@ browse pkgmdl = convert' . sort =<< (listExports =<< getModule)
 -- >>> splitPkgMdl "Prelude"
 -- (Nothing,"Prelude")
 splitPkgMdl :: String -> (Maybe String,String)
-splitPkgMdl pkgmdl = case break (==':') pkgmdl of
+splitPkgMdl pkgmdl =
-    (mdl,"")    -> (Nothing,mdl)
+  case break (==':') pkgmdl of
-    (pkg,_:mdl) -> (Just pkg,mdl)
+    (mdl, "")    -> (Nothing, mdl)
+    (pkg, _:mdl) -> (Just pkg, mdl)
 
 -- Haskell 2010:
 -- small -> ascSmall | uniSmall | _
@@ -71,22 +75,23 @@ isNotOp :: String -> Bool
 isNotOp (h:_) = isAlpha h || (h == '_')
 isNotOp _ = error "isNotOp"
 
-processExports :: IOish m => ModuleInfo -> GhcModT m [String]
+processExports :: (G.GhcMonad m, MonadIO m, ExceptionMonad m)
-processExports minfo = do
+               => Options -> ModuleInfo -> m [String]
-  opt <- options
+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 @@ showExport opt minfo e = do
       | null nm    = error "formatOp"
       | isNotOp nm = nm
       | otherwise  = "(" ++ nm ++ ")"
-    inOtherModule :: IOish m => Name -> GhcModT m (Maybe TyThing)
+    inOtherModule :: Name -> m (Maybe TyThing)
-    inOtherModule nm = G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm
+    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 @@ tyType typ
       && 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

Language/Haskell/GhcMod/Cabal18.hs

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

Language/Haskell/GhcMod/Cabal21.hs

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

Language/Haskell/GhcMod/CabalApi.hs

@@ -1,193 +0,0 @@
-{-# LANGUAGE OverloadedStrings, CPP #-}
-
-module Language.Haskell.GhcMod.CabalApi (
-    getCompilerOptions
-  , parseCabalFile
-  , cabalAllBuildInfo
-  , cabalDependPackages
-  , cabalSourceDirs
-  , cabalAllTargets
-  , cabalConfigDependencies
-  ) where
-
-import Language.Haskell.GhcMod.CabalConfig
-import Language.Haskell.GhcMod.Error
-import Language.Haskell.GhcMod.Gap (benchmarkBuildInfo, benchmarkTargets,
-                                    toModuleString)
-import Language.Haskell.GhcMod.GhcPkg
-import Language.Haskell.GhcMod.Types
-
-import MonadUtils (liftIO)
-import Control.Applicative ((<$>))
-import qualified Control.Exception as E
-import Control.Monad (filterM)
-import Data.Maybe (maybeToList)
-import Data.Set (fromList, toList)
-import Distribution.Package (Dependency(Dependency)
-                           , PackageName(PackageName))
-import qualified Distribution.Package as C
-import Distribution.PackageDescription (PackageDescription, BuildInfo, TestSuite, TestSuiteInterface(..), Executable)
-import qualified Distribution.PackageDescription as P
-import Distribution.PackageDescription.Configuration (finalizePackageDescription)
-import Distribution.PackageDescription.Parse (readPackageDescription)
-import Distribution.Simple.Compiler (CompilerId(..), CompilerFlavor(..))
-import Distribution.Simple.Program 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

Language/Haskell/GhcMod/CabalConfig.hs

@@ -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)

Language/Haskell/GhcMod/CabalHelper.hs

@@ -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

Language/Haskell/GhcMod/Caching.hs

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

Language/Haskell/GhcMod/Caching/Types.hs

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

Language/Haskell/GhcMod/CaseSplit.hs

@@ -8,17 +8,24 @@ import Data.List (find, intercalate)
 import Data.Maybe (isJust)
 import qualified Data.Text as T
 import qualified Data.Text.IO as T (readFile)
+import System.FilePath
+
 import qualified DataCon as Ty
-import Exception (ghandle, SomeException(..))
 import GHC (GhcMonad, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
 import qualified GHC as G
-import Language.Haskell.GhcMod.Convert
-import qualified Language.Haskell.GhcMod.Gap as Gap
-import Language.Haskell.GhcMod.Monad
-import Language.Haskell.GhcMod.SrcUtils
 import Outputable (PprStyle)
 import qualified TyCon as Ty
 import qualified Type as Ty
+import Exception
+
+import Language.Haskell.GhcMod.Convert
+import Language.Haskell.GhcMod.DynFlags
+import qualified Language.Haskell.GhcMod.Gap as Gap
+import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.SrcUtils
+import Language.Haskell.GhcMod.Doc
+import Language.Haskell.GhcMod.Logging
+import Language.Haskell.GhcMod.Types
 
 ----------------------------------------------------------------
 -- CASE SPLITTING
@@ -38,23 +45,29 @@ splits :: IOish m
        -> Int          -- ^ Line number.
        -> Int          -- ^ Column number.
        -> GhcModT m String
-splits file lineNo colNo = ghandle handler body
+splits file lineNo colNo =
-  where
+  ghandle handler $ runGmlT' [Left file] deferErrors $ do
-    body = inModuleContext file $ \dflag style -> do
       opt <- options
-        modSum <- Gap.fileModSummary file
+      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
-             text <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
+          t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
                                              getTyCons dflag style varName varT)
-             return (fourInts bndLoc, text)
+          return (fourInts bndLoc, t)
         (TySplitInfo varName bndLoc (varLoc,varT)) -> do
           let varName' = showName dflag style varName  -- Convert name to string
-             text <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
+          t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
                                              getTyCons dflag style varName varT)
-             return (fourInts bndLoc, text)
+          return (fourInts bndLoc, t)
-    handler (SomeException _) = emptyResult =<< options
+ 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 @@ getSrcSpanTypeForFnSplit modSum lineNo colNo = do
         varT <- Gap.getType tcm varPat'  -- Finally we get the type of the var
         case varT of
           Just varT' ->
+#if __GLASGOW_HASKELL__ >= 710
+            let (L matchL (G.Match _ _ _ (G.GRHSs rhsLs _))) = match
+#else
             let (L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match
+#endif
             in return $ Just (SplitInfo (getPatternVarName varPat') matchL varT' (map G.getLoc rhsLs) )
           _ -> return Nothing
 
@@ -178,15 +195,16 @@ showFieldNames dflag style v (x:xs) = let fName = showName dflag style x
 ----------------------------------------------------------------
 -- 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
+  t <- T.readFile file
-  return $ getCaseSplitText (T.lines text) info
+  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 @@ getCaseSplitText text (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS
    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 @@ srcSpanDifference b v =
    in (vsl - bsl, vsc - bsc, vel - bsl, vec - bsc) -- assume variable in one line
 
 replaceVarWithTyCon :: [T.Text] -> (Int,Int,Int,Int) -> String -> String -> [T.Text]
-replaceVarWithTyCon text (vsl,vsc,_,vec) varname tycon =
+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 @@ replaceVarWithTyCon text (vsl,vsc,_,vec) varname tycon =
                           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 =

Language/Haskell/GhcMod/Check.hs

@@ -5,12 +5,12 @@ module Language.Haskell.GhcMod.Check (
   , 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.Monad
-import Language.Haskell.GhcMod.Target (setTargetFiles)
 
 ----------------------------------------------------------------
 
@@ -29,15 +29,12 @@ checkSyntax files = either id id <$> check files
 check :: IOish m
       => [FilePath]  -- ^ The target files.
       -> GhcModT m (Either String String)
-{-
+check files =
-check fileNames = overrideGhcUserOptions $ \ghcOpts -> do
+    runGmlTWith
-  withLogger (setAllWarningFlags . setNoMaxRelevantBindings . Gap.setWarnTypedHoles . Gap.setDeferTypeErrors) $ do
+      (map Left files)
-    _ <- G.setSessionDynFlags =<< addCmdOpts ghcOpts =<< G.getSessionDynFlags
+      return
-    setTargetFiles fileNames
+      ((fmap fst <$>) . withLogger setNoMaxRelevantBindings)
--}
+      (return ())
-check fileNames =
-  withLogger (setAllWarningFlags . setNoMaxRelevantBindings) $
-    setTargetFiles fileNames
 
 ----------------------------------------------------------------
 
@@ -51,8 +48,10 @@ expandTemplate files = either id id <$> expand files
 ----------------------------------------------------------------
 
 -- | Expanding Haskell Template.
-expand :: IOish m
+expand :: IOish m => [FilePath] -> GhcModT m (Either String String)
-       => [FilePath]  -- ^ The target files.
+expand files =
-       -> GhcModT m (Either String String)
+    runGmlTWith
-expand fileNames = withLogger (Gap.setDumpSplices . setNoWarningFlags) $
+      (map Left files)
-    setTargetFiles fileNames
+      return
+      ((fmap fst <$>) . withLogger (Gap.setDumpSplices . setNoWarningFlags))
+      (return ())

Language/Haskell/GhcMod/Convert.hs

@@ -1,11 +1,12 @@
-{-# LANGUAGE FlexibleInstances, FlexibleContexts, OverlappingInstances #-}
+{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-}
 
 module Language.Haskell.GhcMod.Convert (convert, convert', emptyResult, whenFound, whenFound') where
 
-import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.Monad.Types
 import Language.Haskell.GhcMod.Types
 
-import Control.Applicative ((<$>))
+import Control.Applicative
+import Prelude
 
 type Builder = String -> String
 
@@ -23,7 +24,7 @@ inter :: Char -> [Builder] -> Builder
 inter _ [] = id
 inter c bs = foldr1 (\x y -> x . (c:) . y) bs
 
-convert' :: (ToString a, IOish m) => a -> GhcModT m String
+convert' :: (ToString a, IOish m, GmEnv m) => a -> m String
 convert' x = flip convert x <$> options
 
 convert :: ToString a => Options -> a -> String
@@ -64,6 +65,10 @@ instance ToString [String] where
   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)]

Language/Haskell/GhcMod/Cradle.hs

@@ -1,19 +1,22 @@
 module Language.Haskell.GhcMod.Cradle (
     findCradle
   , findCradle'
-  , findCradleWithoutSandbox
+  , findSpecCradle
   , cleanupCradle
   ) where
 
-import Language.Haskell.GhcMod.GhcPkg
 import Language.Haskell.GhcMod.PathsAndFiles
+import Language.Haskell.GhcMod.Monad.Types
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Utils
 
-import Control.Exception.IOChoice ((||>))
+import Control.Applicative
-import System.Directory (getCurrentDirectory, removeDirectoryRecursive)
+import Control.Monad
-import System.FilePath (takeDirectory)
+import Control.Monad.Trans.Maybe
-
+import Data.Maybe
+import System.Directory
+import System.FilePath
+import Prelude
 
 ----------------------------------------------------------------
 
@@ -25,51 +28,62 @@ findCradle :: IO Cradle
 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
+    sbDir <- MaybeT $ findCabalSandboxDir wdir
-    pkgDbStack <- getPackageDbStack sbDir
-    tmpDir <- newTempDir sbDir
     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 {
-    return Cradle {
+        cradleProjectType = PlainProject
-        cradleCurrentDir = wdir
+      , 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

Language/Haskell/GhcMod/Debug.hs

@@ -1,39 +1,127 @@
-module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo) where
+module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo, componentInfo) where
 
-import Control.Applicative ((<$>))
+import Control.Arrow (first)
-import Data.List (intercalate)
+import Control.Applicative
-import Data.Maybe (isJust, fromJust)
+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
+debugInfo = do
-    CompilerOptions gopts incDir pkgs <-
+    Options {..} <- options
-        if isJust $ cradleCabalFile c then
+    Cradle {..} <- cradle
-            fromCabalFile c ||> simpleCompilerOption
+
-          else
+    cabal <-
-            simpleCompilerOption
+        case cradleProjectType of
-    return [
+          CabalProject -> cabalDebug
-        "Root directory:      " ++ cradleRootDir c
+          _ -> return []
-      , "Current directory:   " ++ cradleCurrentDir c
+
-      , "Cabal file:          " ++ show (cradleCabalFile c)
+    pkgOpts <- packageGhcOptions
-      , "GHC options:         " ++ unwords gopts
+
-      , "Include directories: " ++ unwords incDir
+    return $ unlines $
-      , "Dependent packages:  " ++ intercalate ", " (map showPkg pkgs)
+      [ "Root directory:       " ++ cradleRootDir
-      , "System libraries:    " ++ ghcLibDir
+      , "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
-    simpleCompilerOption = options >>= \op ->
+   zipMap f l = l `zip` (f `map` l)
-        return $ CompilerOptions (ghcUserOptions op) [] []
-    fromCabalFile c = options >>= \opts -> do
-        pkgDesc <- parseCabalFile c $ fromJust $ cradleCabalFile c
-        getCompilerOptions (ghcUserOptions opts) c pkgDesc
 
+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.

Language/Haskell/GhcMod/Doc.hs

@@ -1,9 +1,8 @@
 module Language.Haskell.GhcMod.Doc where
 
-import GHC (DynFlags, GhcMonad)
+import GHC
-import qualified GHC as G
 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 @@ showPage dflag style = showDocWith dflag PageMode . withStyle dflag style
 showOneLine :: DynFlags -> PprStyle -> SDoc -> String
 showOneLine dflag style = showDocWith dflag OneLineMode . withStyle dflag style
 
+-- showForUser :: DynFlags -> PrintUnqualified -> SDoc -> String
+-- showForUser dflags unqual sdoc =
+--     showDocWith dflags PageMode $
+--       runSDoc sdoc $ initSDocContext dflags $ mkUserStyle unqual AllTheWay
+
 getStyle :: GhcMonad m => m PprStyle
 getStyle = do
-    unqual <- G.getPrintUnqual
+    unqual <- getPrintUnqual
     return $ mkUserStyle unqual AllTheWay
 
 styleUnqualified :: PprStyle

Language/Haskell/GhcMod/DynFlags.hs

@@ -2,7 +2,7 @@
 
 module Language.Haskell.GhcMod.DynFlags where
 
-import Control.Applicative ((<$>))
+import Control.Applicative
 import Control.Monad (void)
 import GHC (DynFlags(..), GhcMode(..), GhcLink(..), HscTarget(..))
 import qualified GHC as G
@@ -11,8 +11,7 @@ import GhcMonad
 import qualified Language.Haskell.GhcMod.Gap as Gap
 import Language.Haskell.GhcMod.Types
 import System.IO.Unsafe (unsafePerformIO)
-
+import Prelude
-data Build = CabalPkg | SingleFile deriving Eq
 
 setEmptyLogger :: DynFlags -> DynFlags
 setEmptyLogger df = Gap.setLogAction df $ \_ _ _ _ _ -> return ()
@@ -41,37 +40,15 @@ setModeIntelligent df = df {
   , 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 @@ setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing }
 #else
 setNoMaxRelevantBindings = id
 #endif
+
+deferErrors :: DynFlags -> Ghc DynFlags
+deferErrors df = return $
+  Gap.setWarnTypedHoles $ Gap.setDeferTypeErrors $ setNoWarningFlags df

Language/Haskell/GhcMod/Error.hs

@@ -1,45 +1,88 @@
-{-# 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 Data.Version
-import Exception
+import System.Process (showCommandForUser)
 import Text.PrettyPrint
+import Text.Printf
 
-data GhcModError = GMENoMsg
+import Exception
-                 -- ^ Unknown error
+import Panic
-                 | GMEString String
+import Config (cProjectVersion, cHostPlatformString)
-                 -- ^ Some Error with a message. These are produced mostly by
+import Paths_ghc_mod (version)
-                 -- '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)
 
-instance Exception GhcModError
+import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Pretty
 
-instance Error GhcModError where
+type GmError m = MonadError GhcModError m
-    noMsg = GMENoMsg
+
-    strMsg = GMEString
+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
@@ -47,20 +90,83 @@ gmeDoc e = case e of
         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
+        text "Retrieval of the cabal configuration flags failed: " <> gmeDoc msg
-    GMEProcess cmd msg ->
+    GMECabalComponent cn ->
-        text ("launching operating system process `"++unwords cmd++"` failed: ")
+        text "Cabal component " <> quotes (gmComponentNameDoc cn)
-          <> gmeDoc msg
+                                <> 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 @@ infixr 0 `modifyError'`
 modifyError' :: MonadError e m => m a -> (e -> e) -> m a
 modifyError' = flip modifyError
 
+
+modifyGmError :: (MonadIO m, ExceptionMonad m)
+              => (GhcModError -> GhcModError) -> m a -> m a
+modifyGmError f a = gcatch a $ \(ex :: GhcModError) -> liftIO $ throwIO (f ex)
+
 tryFix :: MonadError e m => m a -> (e -> m ()) -> m a
-tryFix action fix = do
+tryFix action f = do
-  action `catchError` \e -> fix e >> action
+  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

Language/Haskell/GhcMod/FillSig.hs

@@ -11,7 +11,8 @@ import Data.Char (isSymbol)
 import Data.Function (on)
 import Data.List (find, nub, sortBy)
 import qualified Data.Map as M
-import Data.Maybe (isJust, catMaybes)
+import 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 GHC as G
 import qualified Name as G
 import qualified Language.Haskell.GhcMod.Gap as Gap
 import Language.Haskell.GhcMod.Convert
+import Language.Haskell.GhcMod.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 HsPat as Ty
 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 @@ sig :: IOish m
     -> Int          -- ^ Line number.
     -> Int          -- ^ Column number.
     -> GhcModT m String
-sig file lineNo colNo = ghandle handler body
+sig file lineNo colNo =
-  where
+    runGmlT' [Left file] deferErrors $ ghandle fallback $ do
-    body = inModuleContext file $ \dflag style -> do
       opt <- options
+      style <- getStyle
+      dflag <- G.getSessionDynFlags
       modSum <- Gap.fileModSummary file
-        whenFound opt (getSignature modSum lineNo colNo) $ \s -> case s of
+      whenFound opt (getSignature modSum lineNo colNo) $ \s ->
+        case s of
           Signature loc names ty ->
               ("function", fourInts loc, map (initialBody dflag style ty) names)
+
           InstanceDecl loc cls ->
-             ("instance", fourInts loc, map (\x -> initialBody dflag style (G.idType x) x)
+            let body x = initialBody dflag style (G.idType x) x
-                                            (Ty.classMethods cls))
+            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])
+                body = initialFamBody dflag style name vars
-
+            in (rTy, fourInts loc, [initial ++ body])
-    handler (SomeException _) = do
+  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 @@ getSignature modSum lineNo colNo = do
     p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum
     -- Inspect the parse tree to find the signature
     case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsDecl G.RdrName] of
+#if __GLASGOW_HASKELL__ >= 710
+      [L loc (G.SigD (Ty.TypeSig names (L _ ty) _))] ->
+#else
       [L loc (G.SigD (Ty.TypeSig names (L _ ty)))] ->
+#endif
         -- We found a type signature
         return $ Just $ Signature loc (map G.unLoc names) ty
       [L _ (G.InstD _)] -> do
@@ -125,7 +143,12 @@ getSignature modSum lineNo colNo = do
                         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
@@ -144,7 +167,8 @@ getSignature modSum lineNo colNo = do
                       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 :: String -> [FnArg] -> [String] -> String
 initialHead1 fname args elts =
   case initialBodyArgs1 args elts of
     []      -> fname
-    arglist -> if isSymbolName fname
+    arglist
-               then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)
+      | isSymbolName fname ->
-               else fname ++ " " ++ unwords arglist
+        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 @@ class FnArgsInfo ty name | ty -> name, name -> ty where
 
 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,10 +339,12 @@ refine :: IOish m
        -> Int          -- ^ Column number.
        -> Expression   -- ^ A Haskell expression.
        -> GhcModT m String
-refine file lineNo colNo expr = ghandle handler body
+refine file lineNo colNo (Expression expr) =
-  where
+  ghandle handler $
-    body = inModuleContext file $ \dflag style -> do
+    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
@@ -316,33 +356,44 @@ refine file lineNo colNo expr = ghandle handler body
                 diffArgs' = length eArgs - length rArgs
                 diffArgs  = if diffArgs' < 0 then 0 else diffArgs'
                 iArgs = take diffArgs eArgs
-                  text = initialHead1 expr iArgs (infinitePrefixSupply name)
+                txt = initialHead1 expr iArgs (infinitePrefixSupply name)
-               in (fourInts loc, doParen paren text)
+             in (fourInts loc, doParen paren txt)
-
+  where
-    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
+findVar
-                      -> G.TypecheckedModule -> G.TypecheckedSource
+  :: GhcMonad m
-                      -> Int -> Int -> m (Maybe (SrcSpan, String, Type, Bool))
+  => 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) $
+  case lst of
-                listifySpans tcs (lineNo, colNo) :: [G.LHsExpr Id]
+    e@(L _ (G.HsVar i)):others -> do
-  in case lst of
+      tyInfo <- Gap.getType tcm e
-      e@(L _ (G.HsVar i)):others ->
+      case tyInfo of
-        do tyInfo <- Gap.getType tcm e
+        Just (s, typ)
-           let name = getFnName dflag style i
+          | name == "undefined" || head name == '_' ->
-           if (name == "undefined" || head name == '_') && isJust tyInfo
+            return $ Just (s, name, typ, b)
-              then let Just (s,t) = tyInfo
+          where
-                       b = case others of  -- If inside an App, we need
+            name = getFnName dflag style i
-                                           -- parenthesis
+            -- If inside an App, we need parenthesis
-                             [] -> False
+            b = case others of
                   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
+    _ -> 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 @@ auto :: IOish m
      -> Int          -- ^ Line number.
      -> Int          -- ^ Column number.
      -> GhcModT m String
-auto file lineNo colNo = ghandle handler body
+auto file lineNo colNo =
-  where
+  ghandle handler $ runGmlT' [Left file] deferErrors $ do
-    body = inModuleContext file $ \dflag style -> do
         opt <- options
+        style <- getStyle
+        dflag <- G.getSessionDynFlags
         modSum <- Gap.fileModSummary file
         p <- G.parseModule modSum
         tcm@TypecheckedModule {
@@ -395,8 +447,11 @@ auto file lineNo colNo = ghandle handler body
           djinns <- djinn True (Just minfo) env rty (Max 10) 100000
           return ( fourInts loc
                  , map (doParen paren) $ nub (djinnsEmpty ++ djinns))
-
+ where
-    handler (SomeException _) = emptyResult =<< options
+   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 @@ getPatsForVariable tcs (lineNo, colNo) =
 #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.PrefixCon args) =
 getBindingsForRecPat (Ty.InfixCon (L _ a1) (L _ a2)) =
     M.union (getBindingsForPat a1) (getBindingsForPat a2)
 getBindingsForRecPat (Ty.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) =
-    getBindingsForRecFields fields
+    getBindingsForRecFields (map unLoc' fields)
- where getBindingsForRecFields [] = M.empty
+ 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)

Language/Haskell/GhcMod/Find.hs

@@ -1,9 +1,8 @@
-{-# LANGUAGE CPP, BangPatterns #-}
+{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse #-}
 
 module Language.Haskell.GhcMod.Find
 #ifndef SPEC
-  (
+  ( Symbol
-    Symbol
   , SymbolDb
   , loadSymbolDb
   , lookupSymbol
@@ -15,65 +14,51 @@ module Language.Haskell.GhcMod.Find
 #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
+import Prelude
 
-#ifndef MIN_VERSION_containers
-#define MIN_VERSION_containers(x,y,z) 1
-#endif
-
-#if MIN_VERSION_containers(0,5,0)
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as M
-#else
 import Data.Map (Map)
 import qualified Data.Map as M
-#endif
 
 ----------------------------------------------------------------
 
 -- | Type of function and operation names.
 type Symbol = String
 -- | Database from 'Symbol' to \['ModuleString'\].
-data SymbolDb = SymbolDb {
+data SymbolDb = SymbolDb
-    table :: Map Symbol [ModuleString]
+  { table             :: Map Symbol [ModuleString]
-  , packageCachePath :: FilePath
   , symbolDbCachePath :: FilePath
   } deriving (Show)
 
-isOutdated :: SymbolDb -> IO Bool
+isOutdated :: IOish m => SymbolDb -> GhcModT m Bool
-isOutdated db = symbolDbCachePath db `isOlderThan` packageCachePath db
+isOutdated db =
-
+  (liftIO . isOlderThan (symbolDbCachePath db)) =<< timedPackageCaches
-----------------------------------------------------------------
-
--- | 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"
 
 ----------------------------------------------------------------
 
 -- | 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 :: IOish m => Symbol -> SymbolDb -> GhcModT m String
 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 :: IOish m => FilePath -> GhcModT m SymbolDb
-loadSymbolDb = do
+loadSymbolDb dir = do
   ghcMod <- liftIO ghcModExecutable
-    tmpdir <- cradleTempDir <$> cradle
+  readProc <- gmReadProcess
-    file <- chop <$> readProcess' ghcMod ["dumpsym", tmpdir]
+  file   <- liftIO $ chop <$> readProc ghcMod ["dumpsym", dir] ""
   !db    <- M.fromAscList . map conv . lines <$> liftIO (readFile file)
-    return $ SymbolDb {
+  return $ SymbolDb
-        table = db
+    { table             = db
-      , packageCachePath = takeDirectory file </> packageCache
     , 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 @@ loadSymbolDb = do
 
 dumpSymbol :: IOish m => FilePath -> GhcModT m String
 dumpSymbol dir = do
-    let cache = dir </> symbolCache
+  create <- (liftIO . isOlderThan cache) =<< timedPackageCaches
-        pkgdb = dir </> packageCache
+  runGmPkgGhc $ do
-
+    when create $
-    create <- liftIO $ cache `isOlderThan` pkgdb
+      liftIO . writeSymbolCache cache =<< getGlobalSymbolTable
-    when create $ (liftIO . writeSymbolCache cache) =<< getSymbolTable
     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
+-- | Check whether given file is older than any file from the given set.
-isOlderThan cache file = do
+-- Returns True if given file does not exist.
+isOlderThan :: FilePath -> [TimedFile] -> IO Bool
+isOlderThan cache files = do
   exist <- doesFileExist cache
-    if not exist then
+  if not exist
-        return True
+  then return True
   else do
     tCache <- getModificationTime cache
-        tFile <- getModificationTime file
+    return $ any (tCache <=) $ map tfTime files -- including equal just in case
-        return $ tCache <= tFile -- including equal just in case
-
--- | Browsing all functions in all system/user modules.
-getSymbolTable :: IOish m => GhcModT m [(Symbol,[ModuleString])]
-getSymbolTable = do
-    ghcModules <- G.packageDbModules True
-    moduleInfos <- mapM G.getModuleInfo ghcModules
-    let modules = do
-         m <- ghcModules
-         let moduleName = G.moduleNameString $ G.moduleName m
---             modulePkg = G.packageIdString $ G.modulePackageId m
-         return moduleName
 
+-- | 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` modules)
+         $ extractBindings `concatMap` (moduleInfos `zip` mods)
 
-extractBindings :: (Maybe G.ModuleInfo, ModuleString)
+extractBindings :: (Maybe G.ModuleInfo, G.Module)
                 -> [(Symbol, ModuleString)]
-extractBindings (Nothing,_)  = []
+extractBindings (Nothing,  _)   = []
-extractBindings (Just inf,mdlname) =
+extractBindings (Just inf, mdl) =
-    map (\name -> (getOccString name, mdlname)) names
+  map (\name -> (getOccString name, modStr)) names
   where
     names  = G.modInfoExports inf
+    modStr = ModuleString $ moduleNameString $ moduleName mdl
 
-collectModules :: [(Symbol,ModuleString)]
+collectModules :: [(Symbol, ModuleString)]
-               -> [(Symbol,[ModuleString])]
+               -> [(Symbol, [ModuleString])]
 collectModules = map tieup . groupBy ((==) `on` fst) . sort
   where
     tieup x = (head (map fst x), map snd x)

Language/Haskell/GhcMod/GHCApi.hs

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

Language/Haskell/GhcMod/GHCChoice.hs

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

Language/Haskell/GhcMod/Gap.hs

@@ -13,7 +13,6 @@ module Language.Haskell.GhcMod.Gap (
   , showSeverityCaption
   , setCabalPkg
   , setHideAllPackages
-  , addPackageFlags
   , setDeferTypeErrors
   , setWarnTypedHoles
   , setDumpSplices
@@ -33,14 +32,15 @@ module Language.Haskell.GhcMod.Gap (
   , 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 CoreSyn (CoreExpr)
 import Data.List (intersperse)
 import Data.Maybe (catMaybes)
 import Data.Time.Clock (UTCTime)
+import Data.Traversable hiding (mapM)
 import DataCon (dataConRepType)
 import Desugar (deSugarExpr)
 import DynFlags
 import ErrUtils
+import Exception
 import FastString
 import GhcMonad
 import HscTypes
-import Language.Haskell.GhcMod.GHCChoice
-import Language.Haskell.GhcMod.Types
 import NameSet
 import OccName
 import Outputable
@@ -65,8 +65,8 @@ import PprTyThing
 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 Data.Convertible
 import RdrName (rdrNameOcc)
 #endif
 
+#if __GLASGOW_HASKELL__ < 710
+import UniqFM (eltsUFM)
+import Module
+#endif
+
 #if __GLASGOW_HASKELL__ >= 704
 import qualified Data.IntSet as I (IntSet, empty)
-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 @@ toStringBuffer = liftIO . stringToStringBuffer . unlines
 ----------------------------------------------------------------
 
 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 @@ fOptions = [option | (option,_,_,_) <- fFlags]
 ----------------------------------------------------------------
 
 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 @@ withContext action = gbracket setup teardown body
         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 = gopt_set df Opt_HideAllPackages
 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 @@ filterOutChildren get_thing xs
   where
     implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
 
-infoThing :: GhcMonad m => String -> m SDoc
+infoThing :: GhcMonad m => Expression -> m SDoc
-infoThing str = do
+infoThing (Expression str) = do
     names <- parseName str
 #if __GLASGOW_HASKELL__ >= 708
     mb_stuffs <- mapM (getInfo False) names
@@ -413,29 +431,6 @@ emptyWarnFlags = []
 ----------------------------------------------------------------
 ----------------------------------------------------------------
 
-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,7 +440,12 @@ type GLMatchI = LMatch Id
 #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)
@@ -464,12 +464,74 @@ occName :: RdrName -> OccName
 occName = rdrNameOcc
 #endif
 
-----------------------------------------------------------------
 ----------------------------------------------------------------
 
-setFlags :: DynFlags -> DynFlags
+#if __GLASGOW_HASKELL__ < 710
-#if __GLASGOW_HASKELL__ >= 708
+-- Copied from ghc/InteractiveUI.hs
-setFlags df = df `gopt_unset` Opt_SpecConstr -- consume memory if -O2
+allExposedPackageConfigs :: DynFlags -> [PackageConfig]
-#else
+allExposedPackageConfigs df = filter exposed $ eltsUFM $ pkgIdMap $ pkgState df
-setFlags = id
+
+allExposedModules :: DynFlags -> [ModuleName]
+allExposedModules df = concat $ map exposedModules $ allExposedPackageConfigs df
+
+listVisibleModuleNames :: DynFlags -> [ModuleName]
+listVisibleModuleNames = allExposedModules
 #endif
+
+lookupModulePackageInAllPackages ::
+    DynFlags -> ModuleName -> [String]
+lookupModulePackageInAllPackages df mn =
+#if __GLASGOW_HASKELL__ >= 710
+    unpackSPId . sourcePackageId . snd <$> lookupModuleInAllPackages df mn
+ where
+   unpackSPId (SourcePackageId fs) = unpackFS fs
+#else
+    unpackPId . sourcePackageId . fst <$> lookupModuleInAllPackages df mn
+ where
+   unpackPId pid = packageIdString $ mkPackageId pid
+--       n ++ "-" ++ showVersion v
+#endif
+
+listVisibleModules :: DynFlags -> [GHC.Module]
+listVisibleModules df = let
+#if __GLASGOW_HASKELL__ >= 710
+    modNames = listVisibleModuleNames df
+    mods = [ m | mn <- modNames, (m, _) <- lookupModuleInAllPackages df mn ]
+#else
+    pkgCfgs = allExposedPackageConfigs df
+    mods = [ mkModule pid modname | p <- pkgCfgs
+           , let pid = packageConfigId p
+           , modname <- exposedModules p ]
+#endif
+    in mods
+
+isSynTyCon :: TyCon -> Bool
+#if __GLASGOW_HASKELL__ >= 710
+isSynTyCon = GHC.isTypeSynonymTyCon
+#else
+isSynTyCon = GHC.isSynTyCon
+#endif
+
+
+parseModuleHeader
+    :: String         -- ^ Haskell module source text (full Unicode is supported)
+    -> DynFlags
+    -> FilePath       -- ^ the filename (for source locations)
+    -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName))
+parseModuleHeader str dflags filename =
+   let
+       loc  = mkRealSrcLoc (mkFastString filename) 1 1
+       buf  = stringToStringBuffer str
+   in
+   case L.unP Parser.parseHeader (mkPState dflags buf loc) of
+
+     PFailed sp err   ->
+#if __GLASGOW_HASKELL__ >= 706
+         Left (unitBag (mkPlainErrMsg dflags sp err))
+#else
+         Left (unitBag (mkPlainErrMsg sp err))
+#endif
+
+     POk pst rdr_module ->
+         let (warns,_) = getMessages pst in
+         Right (warns, rdr_module)

Language/Haskell/GhcMod/GhcPkg.hs

@@ -4,53 +4,27 @@ module Language.Haskell.GhcMod.GhcPkg (
   , ghcPkgDbStackOpts
   , ghcDbStackOpts
   , ghcDbOpt
-  , fromInstalledPackageId
-  , fromInstalledPackageId'
   , getPackageDbStack
   , getPackageCachePaths
   ) where
 
 import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt)
-import Control.Applicative ((<$>))
+import Control.Applicative
-import Data.List (intercalate)
 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
@@ -85,11 +59,24 @@ ghcDbOpt (PackageDb pkgDb)
 
 ----------------------------------------------------------------
 
+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 :: FilePath -> Cradle -> IO [FilePath]
+getPackageCachePaths :: IOish m => FilePath -> GhcModT m [FilePath]
-getPackageCachePaths sysPkgCfg crdl =
+getPackageCachePaths sysPkgCfg = do
-    catMaybes <$> resolvePackageConfig sysPkgCfg `mapM` cradlePkgDbStack crdl
+  pkgDbStack <- getPackageDbStack
-
+  catMaybes <$> (liftIO . resolvePackageConfig sysPkgCfg) `mapM` pkgDbStack
 
 -- TODO: use PkgConfRef
 --- Copied from ghc module `Packages' unfortunately it's not exported :/

Language/Haskell/GhcMod/HomeModuleGraph.hs

@@ -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

Language/Haskell/GhcMod/Info.hs

@@ -3,20 +3,25 @@ module Language.Haskell.GhcMod.Info (
   , 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,14 +30,22 @@ info :: IOish m
      => FilePath     -- ^ A target file.
      -> Expression   -- ^ A Haskell expression.
      -> GhcModT m String
-info file expr = do
+info file expr =
-    opt <- options
+  ghandle handler $
-    convert opt <$> ghandle handler body
+    runGmlT' [Left file] deferErrors $
+      withContext $
+        convert <$> options <*> body
   where
-    body = inModuleContext file $ \dflag style -> do
+    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
-        return $ showPage dflag style sdoc
+      st    <- getStyle
-    handler (SomeException _) = return "Cannot show info"
+      dflag <- G.getSessionDynFlags
+      return $ showPage dflag st sdoc
 
 ----------------------------------------------------------------
 
@@ -42,15 +55,20 @@ types :: IOish m
       -> Int          -- ^ Line number.
       -> Int          -- ^ Column number.
       -> GhcModT m String
-types file lineNo colNo = do
+types file lineNo colNo =
-    opt <- options
+  ghandle handler $
-    convert opt <$> ghandle handler body
+    runGmlT' [Left file] deferErrors $
-  where
+      withContext $ do
-    body = inModuleContext file $ \dflag style -> do
+        crdl         <- cradle
-        modSum <- Gap.fileModSummary file
+        modSum       <- Gap.fileModSummary (cradleCurrentDir crdl </> file)
         srcSpanTypes <- getSrcSpanType modSum lineNo colNo
-        return $ map (toTup dflag style) $ sortBy (cmp `on` fst) srcSpanTypes
+        dflag        <- G.getSessionDynFlags
-    handler (SomeException _) = return []
+        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

Language/Haskell/GhcMod/Internal.hs

@@ -8,35 +8,33 @@ module Language.Haskell.GhcMod.Internal (
   , PackageVersion
   , PackageId
   , IncludeDir
-  , CompilerOptions(..)
+  , GmlT(..)
-  -- * Cabal API
+  , MonadIO(..)
-  , parseCabalFile
+  , GmEnv(..)
-  , getCompilerOptions
-  , cabalAllBuildInfo
-  , cabalDependPackages
-  , cabalSourceDirs
-  , cabalAllTargets
   -- * 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 @@ module Language.Haskell.GhcMod.Internal (
   , 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

Language/Haskell/GhcMod/Logger.hs

@@ -1,31 +1,33 @@
-{-# LANGUAGE CPP #-}
-
 module Language.Haskell.GhcMod.Logger (
     withLogger
-  , withLoggerTwice
+  , withLogger'
   , checkErrorPrefix
+  , errsToStr
+  , errBagToStrList
   ) where
 
-import Bag (Bag, bagToList, emptyBag, consBag, filterBag, unionBags)
+import Control.Arrow
-import Control.Applicative ((<$>))
+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 GHC (DynFlags, SrcSpan, Severity(SevError))
-import qualified GHC as G
-import HscTypes (SourceError, srcErrorMessages)
-import Language.Haskell.GhcMod.Doc (showPage, getStyle)
-import Language.Haskell.GhcMod.DynFlags (withDynFlags, withCmdFlags)
-import qualified Language.Haskell.GhcMod.Gap as Gap
-import Language.Haskell.GhcMod.Convert (convert')
-import Language.Haskell.GhcMod.Monad
-import Language.Haskell.GhcMod.Types
-import Outputable (PprStyle, SDoc, qualName, qualModule, mkErrStyle, neverQualify)
 import System.FilePath (normalise)
+import Text.PrettyPrint
 
-----------------------------------------------------------------
+import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo)
+import GHC (DynFlags, SrcSpan, Severity(SevError))
+import HscTypes
+import Outputable
+import qualified GHC as G
+import Bag
+
+import Language.Haskell.GhcMod.Convert
+import Language.Haskell.GhcMod.Doc (showPage)
+import Language.Haskell.GhcMod.DynFlags (withDynFlags)
+import Language.Haskell.GhcMod.Monad.Types
+import Language.Haskell.GhcMod.Error
+import qualified Language.Haskell.GhcMod.Gap as Gap
+import Prelude
 
 type Builder = [String] -> [String]
 
@@ -39,178 +41,94 @@ emptyLog = Log [] id
 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
+    Log _ b <- readIORef ref
-    liftIO $ writeIORef ref emptyLog
+    writeIORef ref emptyLog
-    convert' (b [])
+    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 ()
+           -> m a
-           -> GhcModT m (Either String String)
+           -> m (Either String (String, a))
-withLogger setDF body = ghandle sourceError $ do
+withLogger f action = do
-    logref <- liftIO newLogRef
+  env <- G.getSession
-    wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options
+  opts <- options
-    withDynFlags (setLogger logref . setDF) $
+  let conv = convert opts
-        withCmdFlags wflags $ do
+  eres <- withLogger' env $ \setDf ->
-            body
+      withDynFlags (f . setDf) action
-            Right <$> readAndClearLogRef logref
+  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
+
+    let dflags = hsc_dflags env
+        pu = icPrintUnqual dflags (hsc_IC env)
+        st = mkUserStyle pu AllTheWay
+
+        fn df  = setLogger logref df
+
+    a <- gcatches (Right <$> action fn) (handlers dflags st)
+    ls <- liftIO $ readAndClearLogRef logref
+
+    return $ ((,) ls <$> a)
+
   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]
+     ]
 
-withLoggerTwice :: IOish m
+errBagToStrList :: HscEnv -> Bag ErrMsg -> [String]
-                => (DynFlags -> DynFlags)
+errBagToStrList env errs = let
-                -> GhcModT m ()
+    dflags = hsc_dflags env
-                -> (DynFlags -> DynFlags)
+    pu = icPrintUnqual dflags (hsc_IC env)
-                -> GhcModT m ()
+    st = mkUserStyle pu AllTheWay
-                -> GhcModT m (Either String String)
+ in errsToStr dflags st $ bagToList errs
-withLoggerTwice setDF1 body1 setDF2 body2 = do
-  err1 <- ghandle sourceErrorBag $ do
-    logref <- liftIO newLogBagRef
-    wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options
-    withDynFlags (setLogger logref . setDF1) $
-        withCmdFlags wflags $ do
-            body1
-            Right <$> readAndClearLogBagRef logref
-  err2 <- ghandle sourceErrorBag $ do
-    logref <- liftIO newLogBagRef
-    wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options
-    withDynFlags (setLogger logref . setDF2) $
-        withCmdFlags wflags $ do
-            body2
-            Right <$> readAndClearLogBagRef logref
-  -- Merge errors and warnings
-  dflags <- G.getSessionDynFlags
-  style <- getStyle
-  case (err1, err2) of
-    (Right b1, Right b2) -> do let (warn1,_) = mergeErrors dflags style b1 b2
-                               errAndWarnBagToStr Right emptyBag (warn1 `unionBags` b2)
-    (Left  b1, Right b2) -> do let (err,warn) = mergeErrors dflags style b1 b2
-                               errAndWarnBagToStr Right err warn
-    (Right b1, Left  b2) -> do let (err,warn) = mergeErrors dflags style b2 b1
-                               errAndWarnBagToStr Right err warn
-    (Left  b1, Left  b2) -> do let (err1',err2') = mergeErrors dflags style b1 b2
-                               errAndWarnBagToStr Right (err1' `unionBags` err2') emptyBag
-  where
-    setLogger logref df = Gap.setLogAction df $ appendLogBagRef df logref
 
 ----------------------------------------------------------------
 
 -- | Converting 'SourceError' to 'String'.
-sourceError :: IOish m => SourceError -> GhcModT m (Either String String)
+sourceError :: DynFlags -> PprStyle -> SourceError -> [String]
-sourceError err = errBagToStr (srcErrorMessages err)
+sourceError df st src_err = errsToStr df st $ reverse $ bagToList $ srcErrorMessages src_err
 
-errBagToStr :: IOish m => Bag ErrMsg -> GhcModT m (Either String String)
+errsToStr :: DynFlags -> PprStyle -> [ErrMsg] -> [String]
-errBagToStr = errBagToStr' Left
+errsToStr df st = map (ppErrMsg df st)
-
-errBagToStr' :: IOish m => (String -> a) -> Bag ErrMsg -> GhcModT m a
-errBagToStr' f err = do
-    dflags <- G.getSessionDynFlags
-    style <- getStyle
-    ret <- convert' (errBagToStrList dflags style err)
-    return $ f ret
-
-errAndWarnBagToStr :: IOish m => (String -> a) -> Bag ErrMsg -> Bag WarnMsg -> GhcModT m a
-errAndWarnBagToStr f err warn = do
-    dflags <- G.getSessionDynFlags
-    -- style <- toGhcModT getStyle
-#if __GLASGOW_HASKELL__ >= 706
-    let style = mkErrStyle dflags neverQualify
-#else
-    let style = mkErrStyle neverQualify
-#endif
-    ret <- convert' $ nub (errBagToStrList dflags style err ++ warnBagToStrList dflags style warn)
-    return $ f ret
-
-errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String]
-errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList
-
-warnBagToStrList :: DynFlags -> PprStyle -> Bag WarnMsg -> [String]
-warnBagToStrList dflag style = map (ppWarnMsg dflag style) . reverse . bagToList
-
-sourceErrorBag :: IOish m => SourceError -> GhcModT m (Either (Bag ErrMsg) (Bag WarnMsg))
-sourceErrorBag err = return $ Left (srcErrorMessages err)
-
-mergeErrors :: DynFlags -> PprStyle -> Bag ErrMsg -> Bag ErrMsg -> (Bag ErrMsg, Bag ErrMsg)
-mergeErrors dflag style b1 b2 =
-  let b1Msgs = map (\err1 -> let m = ppWarnMsg dflag style err1 in (m, head $ lines m))
-                   (bagToList b1)
-      mustBeB2 = \err2 -> let msg2  = ppWarnMsg dflag style err2
-                              line2 = head $ lines msg2
-                           in not . isJust $ find (\(msg1, line1) -> msg1 == msg2 || (line1 == line2 && isHoleMsg line1)) b1Msgs
-   in (b1, filterBag mustBeB2 b2)
-
-isHoleMsg :: String -> Bool
-isHoleMsg = isInfixOf "Found hole"
 
 ----------------------------------------------------------------
 
 ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String
-ppErrMsg dflag style err = ppMsg spn SevError dflag style msg ++ (if null ext then "" else "\n" ++ ext)
+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)
-
-ppWarnMsg :: DynFlags -> PprStyle -> ErrMsg -> String
-ppWarnMsg dflag style err = ppMsg spn G.SevWarning dflag style msg ++ (if null ext then "" else "\n" ++ ext)
-   where
-     spn = Gap.errorMsgSpan err
-     msg = errMsgShortDoc err
-     ext = showPage dflag style (errMsgExtraInfo err)
 
 ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String
-ppMsg spn sev dflag style msg = prefix ++ cts
+ppMsg spn sev dflag st msg = prefix ++ cts
   where
-    cts  = showPage dflag style msg
+    cts  = showPage dflag st msg
-    prefix = ppMsgPrefix spn sev dflag style cts
+    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

Language/Haskell/GhcMod/Logging.hs

@@ -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 ()

Language/Haskell/GhcMod/Modules.hs

@@ -1,32 +1,26 @@
 module Language.Haskell.GhcMod.Modules (modules) where
 
-import Control.Applicative ((<$>))
+import Control.Arrow
-import Control.Exception (SomeException(..))
+import Data.List
-import Data.List (nub, sort)
-import qualified GHC as G
 import Language.Haskell.GhcMod.Convert
-import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.Types
-import Packages (pkgIdMap, exposedModules, sourcePackageId, display)
+import Language.Haskell.GhcMod.Monad
-import UniqFM (eltsUFM)
+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
+  Options { detailed } <- options
-    convert opt . arrange opt <$> (getModules `G.gcatch` handler)
+  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
-    getModules = getExposedModules <$> G.getSessionDynFlags
+   modulePkg df = lookupModulePackageInAllPackages df
-    getExposedModules = concatMap exposedModules'
-                      . eltsUFM . pkgIdMap . G.pkgState
-    exposedModules' p =
-        map G.moduleNameString (exposedModules p)
-    	`zip`
-        repeat (display $ sourcePackageId p)
-    arrange opt = nub . sort . map (dropPkgs opt)
-    dropPkgs opt (name, pkg)
-      | detailed opt = name ++ " " ++ pkg
-      | otherwise = name
-    handler (SomeException _) = return []

Language/Haskell/GhcMod/Monad.hs

@@ -1,289 +1,100 @@
-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-}
+-- ghc-mod: Making Haskell development *more* fun
-{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-}
+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>
-{-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-}
+--
-{-# LANGUAGE ScopedTypeVariables #-}
+-- This program is free software: you can redistribute it and/or modify
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+-- 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
+    runGhcModT
-    GhcModT
-  , IOish
-  -- ** Environment, state and logging
-  , GhcModEnv(..)
-  , newGhcModEnv
-  , GhcModState(..)
-  , defaultState
-  , CompilerMode(..)
-  , GhcModLog
-  , GhcModError(..)
-  -- * Monad utilities
-  , runGhcModT
   , runGhcModT'
+  , runGhcModT''
   , hoistGhcModT
-  -- ** Accessing 'GhcModEnv' and 'GhcModState'
+  , runGmlT
-  , gmsGet
+  , runGmlT'
-  , gmsPut
+  , runGmlTWith
-  , options
+  , runGmPkgGhc
-  , cradle
+  , withGhcModEnv
-  , getCompilerMode
+  , withGhcModEnv'
-  , setCompilerMode
+  , module Language.Haskell.GhcMod.Monad.Types
-  , withOptions
-  , withTempSession
-  , overrideGhcUserOptions
-  -- ** Re-exporting convenient stuff
-  , liftIO
-  , module Control.Monad.Reader.Class
-  , module Control.Monad.Journal.Class
   ) where
 
-#if __GLASGOW_HASKELL__ < 708
--- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different
--- classes before ghc 7.8
-#define DIFFERENT_MONADIO 1
-
--- RWST doen't have a MonadIO instance before ghc 7.8
-#define MONADIO_INSTANCES 1
-#endif
-
-
 import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.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.Target
-import Language.Haskell.GhcMod.GhcPkg
+import Language.Haskell.GhcMod.Output
-import Language.Haskell.GhcMod.CabalApi
-import qualified Language.Haskell.GhcMod.Gap as Gap
 
-import DynFlags
-import GHC
-import qualified GHC as G
-import GHC.Paths (libdir)
-import GhcMonad hiding (withTempSession)
-#if __GLASGOW_HASKELL__ <= 702
-import HscTypes
-#endif
-
--- MonadUtils of GHC 7.6 or earlier defines its own MonadIO.
--- RWST does not automatically become an instance of MonadIO.
--- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class.
--- So, RWST automatically becomes an instance of MonadIO.
-import MonadUtils
-
-#if DIFFERENT_MONADIO
-import Control.Monad.Trans.Class (lift)
-import qualified Control.Monad.IO.Class
-import Data.Monoid (Monoid)
-#endif
-
-import Control.Applicative (Alternative)
 import Control.Arrow (first)
-import Control.Monad (MonadPlus, void)
+import Control.Applicative
-#if !MIN_VERSION_monad_control(1,0,0)
-import Control.Monad (liftM)
-#endif
-import Control.Monad.Base (MonadBase, liftBase)
 
--- Monad transformer stuff
+import Control.Concurrent
-import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith,
-  control, liftBaseOp, liftBaseOp_)
 
-import Control.Monad.Trans.Class
+import Control.Monad.Reader (runReaderT)
-import Control.Monad.Reader.Class
+import Control.Monad.State.Strict (runStateT)
-import Control.Monad.Writer.Class (MonadWriter)
+import Control.Monad.Trans.Journal (runJournalT)
-import Control.Monad.State.Class (MonadState(..))
 
-import Control.Monad.Error (ErrorT, runErrorT)
+import Exception (ExceptionMonad(..))
-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 System.Directory
-import Data.IORef (IORef, readIORef, writeIORef, newIORef)
+import Prelude
-import System.Directory (getCurrentDirectory)
 
-----------------------------------------------------------------
+withCradle :: IOish m => FilePath -> (Cradle -> m a) -> m a
+withCradle cradledir f =
+    gbracket (liftIO $ findCradle' cradledir) (liftIO . cleanupCradle) f
 
-data GhcModEnv = GhcModEnv {
+withGhcModEnv :: IOish m => FilePath -> Options -> (GhcModEnv -> m a) -> m a
-      gmGhcSession :: !(IORef HscEnv)
+withGhcModEnv dir opt f = withCradle dir (withGhcModEnv' opt f)
-    , 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
 
+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
-       fromEx :: Exception e => SomeException -> e
+   setup c = liftIO $ do
-       fromEx se = let Just e = fromException se in e
+     setCurrentDirectory $ cradleRootDir crdl
-       isIOError se =
+     forkIO $ stdoutGateway c
-           case fromException se of
-             Just (_ :: IOError) -> True
-             Nothing -> False
 
-       isGhcModError se =
+   teardown olddir tid = liftIO $ do
-           case fromException se of
+     setCurrentDirectory olddir
-             Just (_ :: GhcModError) -> True
+     killThread tid
-             Nothing -> False
 
-
+   gbracket_ ma mb mc = gbracket ma mb (const mc)
-instance MonadTrans (GhcModT) where
-    lift = GhcModT . lift . lift . lift . lift
-
-instance MonadState s m => MonadState s (GhcModT m) where
-    get = GhcModT $ lift $ lift $ lift get
-    put = GhcModT . lift . lift . lift . put
-    state = GhcModT . lift . lift . lift . state
-
-
-#if MONADIO_INSTANCES
-instance MonadIO m => MonadIO (StateT s m) where
-    liftIO = lift . liftIO
-
-instance MonadIO m => MonadIO (ReaderT r m) where
-    liftIO = lift . liftIO
-
-instance (Monoid w, MonadIO m) => MonadIO (JournalT w m) where
-    liftIO = lift . liftIO
-
-instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where
-    liftIO = lift . liftIO
-
-instance MonadIO m => MonadIO (MaybeT m) where
-    liftIO = lift . liftIO
-#endif
-
-----------------------------------------------------------------
-
--- | Initialize the 'DynFlags' relating to the compilation of a single
--- file or GHC session according to the 'Cradle' and 'Options'
--- provided.
-initializeFlagsWithCradle :: (IOish m, GhcMonad m, MonadError GhcModError m)
-        => Options
-        -> Cradle
-        -> m ()
-initializeFlagsWithCradle opt c
-  | cabal     = withCabal
-  | otherwise = withSandbox
-  where
-    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
-
-initSession :: GhcMonad m
-            => Build
-            -> Options
-            -> CompilerOptions
-            -> m ()
-initSession build Options {..} CompilerOptions {..} = do
-    df <- G.getSessionDynFlags
-    void $ G.setSessionDynFlags =<< addCmdOpts ghcOptions
-      ( setModeSimple
-      $ Gap.setFlags
-      $ setIncludeDirs includeDirs
-      $ setBuildEnv build
-      $ setEmptyLogger
-      $ Gap.addPackageFlags depPackages df)
-
-----------------------------------------------------------------
-
-newGhcModEnv :: Options -> FilePath -> IO GhcModEnv
-newGhcModEnv opt dir = do
-      session <- newIORef (error "empty session")
-      c <- findCradle' dir
-      return GhcModEnv {
-          gmGhcSession = session
-        , gmOptions = opt
-        , gmCradle = c
-        }
-
-cleanupGhcModEnv :: GhcModEnv -> IO ()
-cleanupGhcModEnv env = cleanupCradle $ gmCradle env
 
 -- | 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
+runGhcModT opt action = do
-    r <- first (fst <$>) <$> (runGhcModT' env defaultState $ do
+    dir <- liftIO getCurrentDirectory
-        dflags <- getSessionDynFlags
+    runGhcModT' dir opt action
-        defaultCleanupHandler dflags $ do
-            initializeFlagsWithCradle opt (gmCradle env)
-            action)
-    return r
 
- where
+runGhcModT' :: IOish m
-   newEnv = liftBase $ newGhcModEnv opt =<< getCurrentDirectory
+            => FilePath
-   delEnv = liftBase . cleanupGhcModEnv
+            -> 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 @@ hoistGhcModT :: IOish m
              => (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 @@ hoistGhcModT (r,l) = do
 -- do with 'GhcModEnv' and 'GhcModState'.
 --
 -- You should probably look at 'runGhcModT' instead.
-runGhcModT' :: IOish m
+runGhcModT'' :: IOish m
              => GhcModEnv
              -> GhcModState
              -> GhcModT m a
              -> m (Either GhcModError (a, GhcModState), GhcModLog)
-runGhcModT' r s a = do
+runGhcModT'' r s a = do
-  (res, w') <-
+  flip runReaderT r $ runJournalT $ runErrorT $ runStateT (unGhcModT a) s
-      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

Language/Haskell/GhcMod/Monad/Types.hs

@@ -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

Language/Haskell/GhcMod/Output.hs

@@ -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 ++ ")"]

Language/Haskell/GhcMod/PathsAndFiles.hs

@@ -1,21 +1,42 @@
-{-# LANGUAGE BangPatterns, TupleSections #-}
+-- ghc-mod: Making Haskell development *more* fun
-module Language.Haskell.GhcMod.PathsAndFiles where
+-- 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 Data.Traversable hiding (mapM)
-import Language.Haskell.GhcMod.Types
+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 Utils (mightExist)
-import Distribution.Simple.BuildPaths (defaultDistPref)
+import Prelude
-import Distribution.Simple.Configure (localBuildInfoFile)
 
 -- | Guaranteed to be a path to a directory with no trailing slash.
 type DirPath = FilePath
@@ -23,40 +44,111 @@ type DirPath = FilePath
 -- | Guaranteed to be the name of a file only (no slashes).
 type FileName = String
 
+newtype UnString = UnString { unString :: String }
+
+instance Show UnString where
+    show = unString
+
+instance Read UnString where
+    readsPrec _ = \str -> [(UnString str, "")]
+
 -- | @findCabalFiles dir@. Searches for a @.cabal@ files in @dir@'s parent
 -- directories. The first parent directory containing more than one cabal file
 -- is assumed to be the project directory. If only one cabal file exists in this
 -- directory it is returned otherwise @findCabalFiles@ throws 'GMENoCabalFile'
 -- or 'GMETooManyCabalFiles'
 findCabalFile :: FilePath -> IO (Maybe FilePath)
-findCabalFile directory = do
+findCabalFile dir = do
-    -- Look for cabal files in @dir@ and all it's parent directories
+    -- List of directories and all cabal file candidates
-    dcs <- getCabalFiles `zipMapM` parents directory
+    dcs <- findFileInParentsP  isCabalFile dir :: IO ([(DirPath, [FileName])])
-    -- Extract first non-empty list, which represents a directory with cabal
+    let css = uncurry appendDir `map` dcs :: [[FilePath]]
-    -- files.
+    case find (not . null) css of
-    case find (not . null) $ uncurry appendDir `map` dcs of
+      Nothing -> return Nothing
-      Just []          -> throw $ GMENoCabalFile
       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
+
+-- | 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)
 
--- | @getCabalFiles dir@. Find all files ending in @.cabal@ in @dir@.
-getCabalFiles :: DirPath -> IO [FileName]
-getCabalFiles dir =
-    filterM isCabalFile =<< getDirectoryContents dir
  where
-   isCabalFile f = do
+   fixPkgDbVer bp dir =
-     exists <- doesFileExist $ dir </> f
+       case takeFileName dir == ghcSandboxPkgDbDir bp of
-     return (exists && takeExtension' f == ".cabal")
+         True -> dir
+         False -> takeDirectory dir </> ghcSandboxPkgDbDir bp
 
-   takeExtension' p = if takeFileName p == takeExtension p
+-- | Extract the sandbox package db directory from the cabal.sandbox.config
-                        then ""
+-- 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 @@ parents dir' =
 
 ----------------------------------------------------------------
 
--- | 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

Language/Haskell/GhcMod/PkgDoc.hs

@@ -5,22 +5,23 @@ import Language.Haskell.GhcMod.GhcPkg
 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
+    pkgDbStack <- getPackageDbStack
-    pkg <- trim <$> readProcess' "ghc-pkg" (toModuleOpts c)
+    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"]
+    toModuleOpts dbs = ["find-module", mdl, "--simple-output"]
-                   ++ ghcPkgDbStackOpts (cradlePkgDbStack c)
+                   ++ ghcPkgDbStackOpts dbs
-    toDocDirOpts pkg c = ["field", pkg, "haddock-html"]
+    toDocDirOpts pkg dbs = ["field", pkg, "haddock-html"]
-                       ++ ghcPkgDbStackOpts (cradlePkgDbStack c)
+                       ++ ghcPkgDbStackOpts dbs
     trim = takeWhile (`notElem` " \n")

Language/Haskell/GhcMod/Pretty.hs

@@ -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

Language/Haskell/GhcMod/SrcUtils.hs

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

Language/Haskell/GhcMod/Target.hs

@@ -1,60 +1,486 @@
-{-# LANGUAGE CPP #-}
+-- ghc-mod: Making Haskell development *more* fun
-module Language.Haskell.GhcMod.Target (
+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>
-    setTargetFiles
+--
-  ) where
+-- This program is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU Affero General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+--
+-- This program is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+-- GNU Affero General Public License for more details.
+--
+-- You should have received a copy of the GNU Affero General Public License
+-- along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+{-# LANGUAGE CPP, ViewPatterns, NamedFieldPuns, RankNTypes #-}
+module 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 Control.Applicative ((<$>))
-import Control.Monad (forM, void, (>=>))
-import DynFlags (ExtensionFlag(..), xopt)
-import GHC (LoadHowMuch(..))
-import qualified GHC as G
 import Language.Haskell.GhcMod.DynFlags
-import Language.Haskell.GhcMod.Monad
+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 ()
+loadTargets :: IOish m => [String] -> GmlT m ()
-setTargetFiles files = do
+loadTargets filesOrModules = do
-    targets <- forM files $ \file -> G.guessTarget file Nothing
+    gmLog GmDebug "loadTargets" $
-    G.setTargets targets
+          text "Loading" <+>: fsep (map text filesOrModules)
+
+    targets <- forM filesOrModules (flip guessTarget Nothing)
+    setTargets targets
+
     mode <- getCompilerMode
-    if mode == Intelligent then
+    if mode == Intelligent
-        loadTargets 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
+    loadTargets' Simple = do
-        -- Reporting error A and error B
+        void $ load LoadAllTargets
-        void $ G.load LoadAllTargets
+        mapM_ (parseModule >=> typecheckModule >=> desugarModule) =<< getModuleGraph
-        mss <- filter (\x -> G.ms_hspp_file x `elem` files) <$> G.getModuleGraph
+
-        -- Reporting error B and error C
+    loadTargets' Intelligent = do
-        mapM_ (G.parseModule >=> G.typecheckModule >=> G.desugarModule) mss
+        df <- getSessionDynFlags
-        -- Error B duplicates. But we cannot ignore both error reportings,
+        void $ setSessionDynFlags (setModeIntelligent df)
-        -- sigh. So, the logger makes log messages unique by itself.
+        void $ load LoadAllTargets
-    loadTargets Intelligent = do
+
-        df <- G.getSessionDynFlags
-        void $ G.setSessionDynFlags (setModeIntelligent df)
-        void $ G.load LoadAllTargets
     resetTargets targets = do
-        G.setTargets []
+        setTargets []
-        void $ G.load LoadAllTargets
+        void $ load LoadAllTargets
-        G.setTargets targets
+        setTargets targets
+
     setIntelligent = do
-        newdf <- setModeIntelligent <$> G.getSessionDynFlags
+        newdf <- setModeIntelligent <$> getSessionDynFlags
-        void $ G.setSessionDynFlags newdf
+        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

Language/Haskell/GhcMod/Types.hs

@@ -1,12 +1,45 @@
-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 @@ import PackageConfig (PackageConfig)
 -- 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 @@ data Options = Options {
     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,41 +95,111 @@ data Options = Options {
   , hlintOpts     :: [String]
   } deriving (Show)
 
-
 -- | A default 'Options'.
 defaultOptions :: Options
 defaultOptions = Options {
     outputStyle    = PlainStyle
-  , hlintOpts     = []
+  , lineSeparator  = LineSeparator "\0"
+  , linePrefix     = Nothing
+  , logLevel       = GmWarning
   , ghcProgram     = "ghc"
+  , ghcPkgProgram  = "ghc-pkg"
   , cabalProgram   = "cabal"
-  , ghcUserOptions= []
+  , ghcUserOptions = []
   , operators      = False
   , detailed       = False
   , qualified      = False
-  , lineSeparator = LineSeparator "\0"
+  , 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
@@ -98,35 +220,166 @@ type PackageId  = String
 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]
+showPkgId (n, v, i) = intercalate "-" [n, v, i]
-
--- | Collection of packages
-type PkgDb = (M.Map Package PackageConfig)
 
 -- | 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
+data GmLogLevel =
-type Module = [String]
+    GmSilent
+  | GmPanic
+  | GmException
+  | GmError
+  | GmWarning
+  | GmInfo
+  | GmDebug
+  | GmVomit
+    deriving (Eq, Ord, Enum, Bounded, Show, Read)
 
--- | Option information for GHC
+-- | Collection of packages
-data CompilerOptions = CompilerOptions {
+type PkgDb = (Map Package PackageConfig)
-    ghcOptions  :: [GHCOption]  -- ^ Command line options
+
-  , includeDirs :: [IncludeDir] -- ^ Include directories for modules
+data GmModuleGraph = GmModuleGraph {
-  , depPackages :: [Package]    -- ^ Dependent package names
+    gmgGraph :: Map ModulePath (Set ModulePath)
-  } deriving (Eq, Show)
+  } 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

Language/Haskell/GhcMod/Utils.hs

@@ -1,67 +1,67 @@
-{-# LANGUAGE CPP #-}
+-- ghc-mod: Making Haskell development *more* fun
-module Language.Haskell.GhcMod.Utils where
+-- 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.Arrow
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DoAndIfThenElse #-}
+
+module Language.Haskell.GhcMod.Utils (
+    module Language.Haskell.GhcMod.Utils
+  , module Utils
+  , readProcess
+  ) where
+
+import Control.Applicative
 import Data.Char
+import Exception
 import Language.Haskell.GhcMod.Error
-import MonadUtils (MonadIO, liftIO)
+import Language.Haskell.GhcMod.Monad.Types
-import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist)
+import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist,
-import System.Exit (ExitCode(..))
+                         getTemporaryDirectory, canonicalizePath)
-import System.Process (readProcessWithExitCode)
-import System.Directory (getTemporaryDirectory)
-import System.FilePath (splitDrive, pathSeparators)
-import System.IO.Temp (createTempDirectory)
-#ifndef SPEC
-import Control.Applicative ((<$>))
 import System.Environment
-import System.FilePath ((</>),takeDirectory)
+import System.FilePath (splitDrive, takeDirectory, takeFileName, pathSeparators,
-#endif
+                        (</>))
+import System.IO.Temp (createTempDirectory)
+import System.Process (readProcess)
+import Text.Printf
+
+import Paths_ghc_mod (getLibexecDir)
+import Utils
+import Prelude
 
 -- dropWhileEnd is not provided prior to base 4.5.0.0.
 dropWhileEnd :: (a -> Bool) -> [a] -> [a]
 dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) []
 
-extractParens :: String -> String
-extractParens str = extractParens' str 0
- where
-   extractParens' :: String -> Int -> String
-   extractParens' [] _ = []
-   extractParens' (s:ss) level
-       | s `elem` "([{" = s : extractParens' ss (level+1)
-       | level == 0 = extractParens' ss 0
-       | s `elem` "}])" && level == 1 = [s]
-       | s `elem` "}])" = s : extractParens' ss (level-1)
-       | otherwise = s : extractParens' ss level
-
-readProcess' :: (MonadIO m, MonadError GhcModError m)
-             => String
-             -> [String]
-             -> m String
-readProcess' cmd opts = do
-  (rv,output,err) <- liftIO (readProcessWithExitCode cmd opts "")
-      `modifyError'` GMEProcess ([cmd] ++ opts)
-  case rv of
-    ExitFailure val -> do
-        throwError $ GMEProcess ([cmd] ++ opts) $ strMsg $
-          cmd ++ " " ++ unwords opts ++ " (exit " ++ show val ++ ")"
-              ++ "\n" ++ err
-    ExitSuccess ->
-        return output
-
 withDirectory_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a
 withDirectory_ dir action =
-    gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory)
+  gbracket
+    (liftIO getCurrentDirectory)
+    (liftIO . setCurrentDirectory)
     (\_ -> liftIO (setCurrentDirectory dir) >> action)
 
 uniqTempDirName :: FilePath -> FilePath
-uniqTempDirName dir = ("ghc-mod"++) $ uncurry (++)
+uniqTempDirName dir =
-        $ map escapeDriveChar *** map escapePathChar
+  "ghc-mod" ++ map escapeDriveChar drive ++ map escapePathChar path
-        $ splitDrive dir
   where
+    (drive, path) = splitDrive dir
+    escapeDriveChar :: Char -> Char
     escapeDriveChar c
       | isAlphaNum c = c
       | otherwise     = '-'
-
+    escapePathChar :: Char -> Char
     escapePathChar c
       | c `elem` pathSeparators = '-'
       | otherwise               = c
@@ -70,25 +70,90 @@ newTempDir :: FilePath -> IO FilePath
 newTempDir dir =
   flip createTempDirectory (uniqTempDirName dir) =<< getTemporaryDirectory
 
-mightExist :: FilePath -> IO (Maybe FilePath)
+whenM :: Monad m => m Bool -> m () -> m ()
-mightExist f = do
+whenM mb ma = mb >>= flip when ma
-  exists <- doesFileExist f
-  return $ if exists then (Just f) else (Nothing)
 
 -- | Returns the path to the currently running ghc-mod executable. With ghc<7.6
 -- this is a guess but >=7.6 uses 'getExecutablePath'.
 ghcModExecutable :: IO FilePath
 #ifndef SPEC
 ghcModExecutable = do
-    dir <- getExecutablePath'
+    dir <- takeDirectory <$> getExecutablePath'
-    return $ dir </> "ghc-mod"
+    return $ (if dir == "." then "" else dir) </> "ghc-mod"
- where
-    getExecutablePath' :: IO FilePath
-# if __GLASGOW_HASKELL__ >= 706
-    getExecutablePath' = takeDirectory <$> getExecutablePath
-# else
-    getExecutablePath' = return ""
-# endif
 #else
-ghcModExecutable = return "dist/build/ghc-mod/ghc-mod"
+ghcModExecutable = fmap (</> "dist/build/ghc-mod/ghc-mod") getCurrentDirectory
 #endif
+
+findLibexecExe :: String -> IO FilePath
+findLibexecExe "cabal-helper-wrapper" = do
+  libexecdir <- getLibexecDir
+  let exeName = "cabal-helper-wrapper"
+      exe = libexecdir </> exeName
+
+  exists <- doesFileExist exe
+
+  if exists
+  then return exe
+  else do
+    mdir <- tryFindGhcModTreeDataDir
+    case mdir of
+      Nothing ->
+        error $ libexecNotExitsError exeName libexecdir
+      Just dir ->
+        return $ dir </> "dist" </> "build" </> exeName </> exeName
+findLibexecExe exe = error $ "findLibexecExe: Unknown executable: " ++ exe
+
+libexecNotExitsError :: String -> FilePath -> String
+libexecNotExitsError exe dir = printf
+ ( "Could not find $libexecdir/%s\n"
+ ++"\n"
+ ++"If you are a developer set the environment variable `ghc_mod_libexecdir'\n"
+ ++"to override $libexecdir[1] the following will work in the ghc-mod tree:\n"
+ ++"\n"
+ ++"    $ export ghc_mod_libexecdir=$PWD/dist/build/%s\n"
+ ++"\n"
+ ++"[1]: %s\n"
+ ++"\n"
+ ++"If you don't know what I'm talking about something went wrong with your\n"
+ ++"installation. Please report this problem here:\n"
+ ++"\n"
+ ++"    https://github.com/kazu-yamamoto/ghc-mod/issues") exe exe dir
+
+tryFindGhcModTreeLibexecDir :: IO (Maybe FilePath)
+tryFindGhcModTreeLibexecDir  = do
+  exe <- getExecutablePath'
+  dir <- case takeFileName exe of
+    "ghc" -> getCurrentDirectory -- we're probably in ghci; try CWD
+    _     -> return $ (!!4) $ iterate takeDirectory exe
+  exists <- doesFileExist $ dir </> "ghc-mod.cabal"
+  return $ if exists
+           then Just dir
+           else Nothing
+
+tryFindGhcModTreeDataDir :: IO (Maybe FilePath)
+tryFindGhcModTreeDataDir  = do
+  dir <- (!!4) . iterate takeDirectory <$> getExecutablePath'
+  exists <- doesFileExist $ dir </> "ghc-mod.cabal"
+  return $ if exists
+           then Just dir
+           else Nothing
+
+readLibExecProcess' :: (MonadIO m, ExceptionMonad m)
+                    => String -> [String] -> m String
+readLibExecProcess' cmd args = do
+  exe <- liftIO $ findLibexecExe cmd
+  liftIO $ readProcess exe args ""
+
+getExecutablePath' :: IO FilePath
+#if __GLASGOW_HASKELL__ >= 706
+getExecutablePath' = getExecutablePath
+#else
+getExecutablePath' = getProgName
+#endif
+
+canonFilePath :: FilePath -> IO FilePath
+canonFilePath f = do
+  p <- canonicalizePath f
+  e <- doesFileExist p
+  when (not e) $ error $ "canonFilePath: not a file: " ++ p
+  return p

Language/Haskell/GhcMod/World.hs

@@ -1,89 +1,52 @@
-{-# LANGUAGE CPP #-}
 module Language.Haskell.GhcMod.World where
-{-(
-  , World
-  , getCurrentWorld
-  , isWorldChanged
-  ) where
--}
 
 import Language.Haskell.GhcMod.GhcPkg
 import Language.Haskell.GhcMod.PathsAndFiles
 import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Monad.Types
 import Language.Haskell.GhcMod.Utils
 
-import Control.Applicative (pure,(<$>),(<*>))
+import Control.Applicative
 import Data.Maybe
-import Data.Traversable (traverse)
+import Data.Traversable hiding (mapM)
-import System.Directory (getModificationTime)
 import System.FilePath ((</>))
 
 import GHC.Paths (libdir)
-
+import Prelude
-#if __GLASGOW_HASKELL__ <= 704
-import System.Time (ClockTime)
-#else
-import Data.Time (UTCTime)
-#endif
-
-
-#if __GLASGOW_HASKELL__ <= 704
-type ModTime = ClockTime
-#else
-type ModTime = UTCTime
-#endif
-
-data TimedFile = TimedFile FilePath ModTime deriving (Eq, Show)
-
-instance Ord TimedFile where
-    compare (TimedFile _ a) (TimedFile _ b) = compare a b
-
-timeFile :: FilePath -> IO TimedFile
-timeFile f = TimedFile <$> pure f <*> getModificationTime f
 
 data World = World {
     worldPackageCaches :: [TimedFile]
   , worldCabalFile     :: Maybe TimedFile
   , worldCabalConfig   :: Maybe TimedFile
+  , worldSymbolCache   :: Maybe TimedFile
   } deriving (Eq, Show)
 
-timedPackageCache :: Cradle -> IO [TimedFile]
+timedPackageCaches :: IOish m => GhcModT m [TimedFile]
-timedPackageCache crdl = do
+timedPackageCaches = do
-    fs <- mapM mightExist . map (</> packageCache)
+    fs <- mapM (liftIO . mightExist) . map (</> packageCache)
-            =<< getPackageCachePaths libdir crdl
+            =<< getPackageCachePaths libdir
-    timeFile `mapM` catMaybes fs
+    (liftIO . timeFile) `mapM` catMaybes fs
 
-getCurrentWorld :: Cradle -> IO World
+getCurrentWorld :: IOish m => GhcModT m World
-getCurrentWorld crdl = do
+getCurrentWorld = do
-    pkgCaches    <- timedPackageCache crdl
+    crdl <- cradle
-    mCabalFile   <- timeFile `traverse` cradleCabalFile crdl
+    pkgCaches    <- timedPackageCaches
-    mSetupConfig <- mightExist (setupConfigFile crdl)
+    mCabalFile   <- liftIO $ timeFile `traverse` cradleCabalFile crdl
-    mCabalConfig <- timeFile `traverse` mSetupConfig
+    mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl)
+    mSymbolCache <- liftIO $ timeMaybe (symbolCache crdl)
 
     return World {
         worldPackageCaches = pkgCaches
       , worldCabalFile     = mCabalFile
       , worldCabalConfig   = mCabalConfig
+      , worldSymbolCache   = mSymbolCache
       }
 
-didWorldChange :: World -> Cradle -> IO Bool
+didWorldChange :: IOish m => World -> GhcModT m Bool
-didWorldChange world crdl = do
+didWorldChange world = do
-    (world /=) <$> getCurrentWorld crdl
+    (world /=) <$> getCurrentWorld
 
--- * Neither file exists -> should return False:
+isYoungerThanSetupConfig :: FilePath -> World -> IO Bool
---   @Nothing < Nothing = False@
+isYoungerThanSetupConfig file World {..} = do
---   (since we don't need to @cabal configure@ when no cabal file exists.)
+  tfile <- timeFile file
---
+  return $ worldCabalConfig < Just tfile
--- * Cabal file doesn't exist (unlikely case) -> should return False
---   @Just cc < Nothing = False@
---   TODO: should we delete dist/setup-config?
---
--- * dist/setup-config doesn't exist yet -> should return True:
---   @Nothing < Just cf = True@
---
--- * Both files exist
---   @Just cc < Just cf = cc < cf = cc `olderThan` cf@
-isSetupConfigOutOfDate :: Cradle -> IO Bool
-isSetupConfigOutOfDate crdl = do
-  world <- getCurrentWorld crdl
-  return $ worldCabalConfig world < worldCabalFile world

NotCPP/COPYING

@@ -1,9 +1,9 @@
--- Copyright   :  Isaac Jones 2003-2004
+Copyright Ben Millwood 2012
-{- All rights reserved.
+
+All rights reserved.
 
 Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
+modification, are permitted provided that the following conditions are met:
-met:
 
     * Redistributions of source code must retain the above copyright
       notice, this list of conditions and the following disclaimer.
@@ -13,7 +13,7 @@ met:
       disclaimer in the documentation and/or other materials provided
       with the distribution.
 
-    * Neither the name of Isaac Jones nor the names of other
+    * Neither the name of Ben Millwood nor the names of other
       contributors may be used to endorse or promote products derived
       from this software without specific prior written permission.
 
@@ -27,19 +27,4 @@ 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. -}
+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)

NotCPP/Declarations.hs

@@ -0,0 +1,164 @@
+-- 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/>.
+
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+{-# LANGUAGE CPP #-}
+-- Using CPP so you don't have to :)
+module NotCPP.Declarations where
+
+import Control.Arrow
+import Control.Applicative
+import Data.Maybe
+import Language.Haskell.TH.Syntax
+
+import NotCPP.LookupValueName
+
+nT :: Monad m => String -> m Type
+cT :: Monad m => String -> m Type
+nE :: Monad m => String -> m Exp
+nP :: Monad m => String -> m Pat
+
+nT str = return $ VarT (mkName str)
+cT str = return $ ConT (mkName str)
+nE str = return $ VarE (mkName str)
+nP str = return $ VarP (mkName str)
+recUpdE' :: Q Exp -> Name -> Exp -> Q Exp
+recUpdE' ex name assign = do
+  RecUpdE <$> ex <*> pure [(name, assign)]
+
+lookupName' :: (NameSpace, String) -> Q (Maybe Name)
+lookupName' (VarName, n) = lookupValueName n
+lookupName' (DataName, n) = lookupValueName n
+lookupName' (TcClsName, n) = lookupTypeName n
+
+-- Does this even make sense?
+ifelseD :: Q [Dec] -> Q [Dec] -> Q [Dec]
+ifelseD if_decls' else_decls = do
+  if_decls <- if_decls'
+  alreadyDefined <- definedNames (boundNames `concatMap` if_decls)
+  case alreadyDefined of
+    [] -> if_decls'
+    _ -> else_decls
+
+ifdefelseD, ifelsedefD :: String -> Q [Dec] -> Q [Dec] -> Q [Dec]
+ifelsedefD = ifdefelseD
+ifdefelseD ident if_decls else_decls = do
+  exists <- isJust <$> lookupValueName ident
+  if exists
+    then if_decls
+    else else_decls
+
+ifdefD :: String -> Q [Dec] -> Q [Dec]
+ifdefD ident decls  = ifdefelseD ident decls (return [])
+
+ifndefD :: String -> Q [Dec] -> Q [Dec]
+ifndefD ident decls  = ifdefelseD ident (return []) decls
+
+-- | Each of the given declarations is only spliced if the identifier it defines
+-- is not defined yet.
+--
+-- For example:
+--
+-- @$(ifD [[d| someFunctionThatShouldExist x = x+1 |]]@
+--
+-- If @someFunctionThatShouldExist@ doesn't actually exist the definition given
+-- in the splice will be the result of the splice otherwise nothing will be
+-- spliced.
+--
+-- Currently this only works for function declarations but it can be easily
+-- extended to other kinds of declarations.
+ifD :: Q [Dec] -> Q [Dec]
+ifD decls' = do
+  decls <- decls'
+  concat <$> flip mapM decls (\decl -> do
+    alreadyDefined <- definedNames (boundNames decl)
+    case alreadyDefined of
+      [] -> return [decl]
+      _ -> return [])
+
+definedNames :: [(NameSpace, Name)] -> Q [Name]
+definedNames ns = catMaybes <$> (lookupName' . second nameBase) `mapM` ns
+
+boundNames :: Dec -> [(NameSpace, Name)]
+boundNames decl =
+    case decl of
+      SigD n _ -> [(VarName, n)]
+      FunD n _cls -> [(VarName, n)]
+#if __GLASGOW_HASKELL__ >= 706
+      InfixD _ n -> [(VarName, n)]
+#endif
+      ValD p _ _ -> map ((,) VarName) $ patNames p
+
+      TySynD n _ _ -> [(TcClsName, n)]
+      ClassD _ n _ _ _ -> [(TcClsName, n)]
+      FamilyD _ n _ _ -> [(TcClsName, n)]
+
+      DataD _ n _ ctors _ ->
+          [(TcClsName, n)] ++ map ((,) TcClsName) (conNames `concatMap` ctors)
+
+      NewtypeD _ n _ ctor _ ->
+          [(TcClsName, n)] ++ map ((,) TcClsName) (conNames ctor)
+
+      DataInstD _ _n _ ctors _ ->
+          map ((,) TcClsName) (conNames `concatMap` ctors)
+
+      NewtypeInstD _ _n _ ctor _ ->
+          map ((,) TcClsName) (conNames ctor)
+
+      InstanceD _ _ty _ ->
+          error "notcpp: Instance declarations are not supported yet"
+      ForeignD _ ->
+          error "notcpp: Foreign declarations are not supported yet"
+      PragmaD _pragma -> error "notcpp: pragmas are not supported yet"
+
+#if __GLASGOW_HASKELL__ >= 708
+      TySynInstD _n _ -> error "notcpp: TySynInstD not supported yet"
+#else
+      TySynInstD _n _ _ -> error "notcpp: TySynInstD not supported yet"
+#endif
+
+#if __GLASGOW_HASKELL__ >= 708
+      ClosedTypeFamilyD n _ _ _ -> [(TcClsName, n)]
+      RoleAnnotD _n _ -> error "notcpp: RoleAnnotD not supported yet"
+#endif
+
+conNames :: Con -> [Name]
+conNames con =
+    case con of
+      NormalC n _ -> [n]
+      RecC n _ -> [n]
+      InfixC _ n _ -> [n]
+      ForallC _ _ c -> conNames c
+
+patNames :: Pat -> [Name]
+patNames p'' =
+    case p'' of
+      LitP _         -> []
+      VarP n         -> [n]
+      TupP ps        -> patNames `concatMap` ps
+      UnboxedTupP ps -> patNames `concatMap` ps
+      ConP _ ps      -> patNames `concatMap` ps
+      InfixP p _ p'  -> patNames `concatMap` [p,p']
+      UInfixP p _ p' -> patNames `concatMap` [p,p']
+      ParensP p      -> patNames p
+      TildeP p       -> patNames p
+      BangP p        -> patNames p
+      AsP n p        -> n:(patNames p)
+      WildP          -> []
+      RecP _ fps     -> patNames `concatMap` map snd fps
+      ListP ps       -> patNames `concatMap` ps
+      SigP p _       -> patNames p
+      ViewP _ p      -> patNames p

NotCPP/LookupValueName.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE TemplateHaskell #-}
+-- | This module uses scope lookup techniques to either export
+-- 'lookupValueName' from @Language.Haskell.TH@, or define
+-- its own 'lookupValueName', which attempts to do the
+-- same job with just 'reify'. This will sometimes fail, but if it
+-- succeeds it will give the answer that the real function would have
+-- given.
+--
+-- The idea is that if you use lookupValueName from this module,
+-- your client code will automatically use the best available name
+-- lookup mechanism. This means that e.g. 'scopeLookup' can work
+-- very well on recent GHCs and less well but still somewhat
+-- usefully on older GHCs.
+module NotCPP.LookupValueName (
+  lookupValueName
+ ) where
+
+import Language.Haskell.TH
+
+import NotCPP.Utils
+
+bestValueGuess :: String -> Q (Maybe Name)
+bestValueGuess s = do
+  mi <- maybeReify (mkName s)
+  case mi of
+    Nothing -> no
+    Just i -> case i of
+      VarI n _ _ _ -> yes n
+      DataConI n _ _ _ -> yes n
+      _ -> err ["unexpected info:", show i]
+ where
+  no = return Nothing
+  yes = return . Just
+  err = fail . showString "NotCPP.bestValueGuess: " . unwords
+
+$(recover [d| lookupValueName = bestValueGuess |] $ do
+  VarI _ _ _ _ <- reify (mkName "lookupValueName")
+  return [])

NotCPP/OrphanEvasion.hs

@@ -0,0 +1,114 @@
+{-# LANGUAGE EmptyDataDecls, TemplateHaskell #-}
+-- | 
+-- The orphan instance problem is well-known in Haskell. This module
+-- by no means purports to solve the problem, but provides a workaround
+-- that may be significantly less awful than the status quo in some
+-- cases.
+--
+-- Say I think that the 'Name' type should have an 'IsString' instance.
+-- But I don't control either the class or the type, so if I define the
+-- instance, and then the template-haskell package defines one, my code
+-- is going to break.
+--
+-- 'safeInstance' can help me to solve this problem:
+--
+-- > safeInstance ''IsString [t| Name |] [d|
+-- >   fromString = mkName |]
+--
+-- This will declare an instance only if one doesn't already exist.
+-- Now anyone importing your module is guaranteed to get an instance
+-- one way or the other.
+--
+-- This module is still highly experimental. The example given above
+-- does work, but anything involving type variables or complex method
+-- bodies may be less fortunate. The names of the methods are mangled
+-- a bit, so using recursion to define them may not work. Define the
+-- method outside the code and then use a simple binding as above.
+--
+-- If you use this code (successfully or unsuccessfully!), go fetch
+-- the maintainer address from the cabal file and let me know!
+module NotCPP.OrphanEvasion (
+  MultiParams,
+  safeInstance,
+  safeInstance',
+ ) where
+
+import Control.Applicative
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+
+import NotCPP.ScopeLookup
+
+-- | An empty type used only to signify a multiparameter typeclass in
+-- 'safeInstance'.
+data MultiParams a
+
+-- | Given @(forall ts. Cxt => t)@, return @(Cxt, [t])@.
+-- Given @(forall ts. Cxt => 'MultiParams' (t1, t2, t3))@, return
+-- @(Cxt, [t1, t2, t3])@.
+--
+-- This is used in 'safeInstance' to allow types to be specified more
+-- easily with TH typequotes.
+fromTuple :: Type -> (Cxt, [Type])
+fromTuple ty = unTuple <$> case ty of
+  ForallT _ cxt ty' -> (cxt, ty')
+  _ -> ([], ty)
+ where
+  unTuple :: Type -> [Type]
+  unTuple (AppT (ConT n) ta)
+    | n == ''MultiParams = case unrollAppT ta of
+      (TupleT{}, ts) -> ts
+      _ -> [ty]
+  unTuple t = [t]
+
+-- | A helper function to unwind type application. 
+-- Given @TyCon t1 t2 t3@, returns @(TyCon, [t1,t2,t3])@
+unrollAppT :: Type -> (Type, [Type])
+unrollAppT = go []
+ where
+  go acc (AppT tc ta) = go (ta : acc) tc
+  go acc ty = (ty, reverse acc)
+
+-- | Left inverse to unrollAppT, equal to @'foldl' 'AppT'@
+rollAppT :: Type -> [Type] -> Type
+rollAppT = foldl AppT
+
+-- | @'safeInstance'' className cxt types methods@ produces an instance
+-- of the given class if and only if one doesn't already exist.
+--
+-- See 'safeInstance' for a simple way to construct the 'Cxt' and
+-- @['Type']@ parameters.
+safeInstance' :: Name -> Cxt -> [Type] -> Q [Dec] -> Q [Dec]
+safeInstance' cl cxt tys inst = do
+  b <- $(scopeLookups ["isInstance", "isClassInstance"]) cl tys
+  if b
+    then return []
+    else do
+      ds <- map fixInst <$> inst
+      return [InstanceD cxt (rollAppT (ConT cl) tys) ds]
+ where
+  fixInst (FunD n cls) = FunD (fixName n) cls
+  fixInst (ValD (VarP n) rhs wh) = ValD (VarP (fixName n)) rhs wh
+  fixInst d = d
+  fixName (Name n _) = Name n NameS
+
+-- | 'safeInstance' is a more convenient version of 'safeInstance''
+-- that takes the context and type from a @'Q' 'Type'@ with the intention
+-- that it be supplied using a type-quote.
+--
+-- To define an instance @Show a => Show (Wrapper a)@, you'd use:
+--
+-- > safeInstance ''Show [t| Show a => Wrapper a |]
+-- >   [d| show _ = "stuff" |]
+--
+-- To define an instance of a multi-param type class, use the
+-- 'MultiParams' type constructor with a tuple:
+--
+-- > safeInstance ''MonadState
+-- >   [t| MonadState s m => MultiParams (s, MaybeT m) |]
+-- >   [d| put = ... |]
+safeInstance :: Name -> Q Type -> Q [Dec] -> Q [Dec]
+safeInstance n qty inst = do
+  (cxt, tys) <- fromTuple <$> qty
+  safeInstance' n cxt tys inst

NotCPP/ScopeLookup.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE TemplateHaskell #-}
+-- |
+-- This module exports 'scopeLookup', which will find a variable or
+-- value constructor for you and present it for your use. E.g. at some
+-- point in the history of the acid-state package, 'openAcidState' was
+-- renamed 'openLocalState'; for compatibility with both, you could
+-- use:
+--
+-- > openState :: IO (AcidState st)
+-- > openState = case $(scopeLookup "openLocalState") of
+-- >   Just open -> open defaultState
+-- >   Nothing -> case $(scopeLookup "openAcidState") of
+-- >     Just open -> open defaultState
+-- >     Nothing -> error
+-- >       "openState: runtime name resolution has its drawbacks :/"
+--
+-- Or, for this specific case, you can use 'scopeLookups':
+--
+-- > openState :: IO (AcidState st)
+-- > openState = open defaultState
+-- >  where
+-- >   open = $(scopeLookups ["openLocalState","openAcidState"])
+--
+-- Now if neither of the names are found then TH will throw a
+-- compile-time error.
+module NotCPP.ScopeLookup (
+  scopeLookup,
+  scopeLookups,
+  scopeLookup',
+  liftMaybe,
+  recoverMaybe,
+  maybeReify,
+  infoToExp,
+ ) where
+
+import Control.Applicative ((<$>))
+
+import Language.Haskell.TH (Q, Exp, recover, reify)
+
+import NotCPP.LookupValueName
+import NotCPP.Utils
+
+-- | Produces a spliceable expression which expands to @'Just' val@ if
+-- the given string refers to a value @val@ in scope, or 'Nothing'
+-- otherwise.
+--
+-- @scopeLookup = 'fmap' 'liftMaybe' . 'scopeLookup''@
+scopeLookup :: String -> Q Exp
+scopeLookup = fmap liftMaybe . scopeLookup'
+
+-- | Finds the first string in the list that names a value, and produces
+-- a spliceable expression of that value, or reports a compile error if
+-- it fails.
+scopeLookups :: [String] -> Q Exp
+scopeLookups xs = foldr
+  (\s r -> maybe r return =<< scopeLookup' s)
+  (fail ("scopeLookups: none found: " ++ show xs))
+  xs
+
+-- | Produces @'Just' x@ if the given string names the value @x@,
+-- or 'Nothing' otherwise.
+scopeLookup' :: String -> Q (Maybe Exp)
+scopeLookup' s = recover (return Nothing) $ do
+  Just n <- lookupValueName s
+  infoToExp <$> reify n

NotCPP/Utils.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE TemplateHaskell #-}
+module NotCPP.Utils where
+
+import Control.Applicative ((<$>))
+import Language.Haskell.TH
+
+-- | Turns 'Nothing' into an expression representing 'Nothing', and
+-- @'Just' x@ into an expression representing 'Just' applied to the
+-- expression in @x@.
+liftMaybe :: Maybe Exp -> Exp
+liftMaybe = maybe (ConE 'Nothing) (AppE (ConE 'Just))
+
+-- | A useful variant of 'reify' that returns 'Nothing' instead of
+-- halting compilation when an error occurs (e.g. because the given
+-- name was not in scope).
+maybeReify :: Name -> Q (Maybe Info)
+maybeReify = recoverMaybe . reify
+
+-- | Turns a possibly-failing 'Q' action into one returning a 'Maybe'
+-- value.
+recoverMaybe :: Q a -> Q (Maybe a)
+recoverMaybe q = recover (return Nothing) (Just <$> q)
+
+-- | Returns @'Just' ('VarE' n)@ if the info relates to a value called
+-- @n@, or 'Nothing' if it relates to a different sort of thing.
+infoToExp :: Info -> Maybe Exp
+infoToExp (VarI n _ _ _) = Just (VarE n)
+infoToExp (DataConI n _ _ _) = Just (ConE n)
+infoToExp _ = Nothing

README.md

@@ -44,7 +44,27 @@ Make sure you're not using the MELPA version of `ghc.el` otherwise you might get
 all sorts of nasty conflicts.
 
 
+## Custom ghc-mod cradle
+
+To customize the package databases used by `ghc-mod`, put a file called `ghc-mod.cradle` beside the `.cabal` file with the following syntax:
+
+```
+temp directory root
+package db 1
+...
+package db n
+```
+
+each package database line is either a *path* to a package database, or `global` or `user`.
+
 ## IRC
 
 If you have any problems, suggestions, comments swing by
-[#ghc-mod](irc://chat.freenode.net/ghc-mod) on Freenode.
+[\#ghc-mod (web client)](https://kiwiirc.com/client/irc.freenode.org/ghc-mod) on
+Freenode. If you're reporting a bug please also create an issue
+[here](https://github.com/kazu-yamamoto/ghc-mod/issues) so we have a way to contact
+you if you don't have time to stay.
+
+Do hang around for a while if no one answers and repeat your question if you
+still haven't gotten any answer after a day or so. You're most likely to get an
+answer during the day in GMT+1.

Setup.hs

@@ -1,2 +1,198 @@
+#!/usr/bin/env runhaskell
+{-# LANGUAGE RecordWildCards #-}
 import Distribution.Simple
-main = defaultMain
+import Distribution.Simple.Setup
+import Distribution.Simple.Install
+import Distribution.Simple.Register
+import Distribution.Simple.InstallDirs as ID
+import Distribution.Simple.LocalBuildInfo
+import Distribution.PackageDescription
+
+import Control.Arrow
+import Control.Applicative
+import Control.Monad
+import Data.List
+import Data.Maybe
+import Data.Version
+import Data.Monoid
+import System.Process
+import System.Exit
+import System.FilePath
+import Text.ParserCombinators.ReadP
+
+import SetupCompat
+
+main :: IO ()
+main = defaultMainWithHooks $ simpleUserHooks {
+   confHook = \(gpd, hbi) cf ->
+              xBuildDependsLike <$> (confHook simpleUserHooks) (gpd, hbi) cf
+
+ , instHook = inst
+ , copyHook = copy
+
+-- , postConf = sanityCheckCabalVersions
+ }
+
+xBuildDependsLike :: LocalBuildInfo -> LocalBuildInfo
+xBuildDependsLike lbi =
+  let
+      cc = componentsConfigs lbi
+      pd = localPkgDescr lbi
+      deps = dependsMap lbi
+  in setComponentsConfigs lbi
+        [ (cn, updateClbi deps comp clbi, cdeps)
+        | (cn, clbi, cdeps) <- cc
+        , let comp = getComponent pd cn
+        ]
+
+ where
+   updateClbi deps comp clbi = setUnionDeps (otherDeps deps comp) clbi
+
+   dependsMap ::
+    LocalBuildInfo -> [(ComponentName, Deps)]
+   dependsMap lbi =
+       second getDeps <$> allComponentsInBuildOrder lbi
+
+   otherDeps :: [(ComponentName, Deps)] -> Component -> Deps
+   otherDeps deps comp = fromMaybe noDeps $
+       flip lookup deps =<< read <$> lookup "x-build-depends-like" fields
+      where
+        fields = customFieldsBI (componentBuildInfo comp)
+
+-- mostly copypasta from 'defaultInstallHook'
+inst ::
+    PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO ()
+inst pd lbi _uf ifl = do
+  let copyFlags = defaultCopyFlags {
+                      copyDistPref   = installDistPref ifl,
+                      copyDest       = toFlag NoCopyDest,
+                      copyVerbosity  = installVerbosity ifl
+                  }
+  xInstallTarget pd lbi (\pd' lbi' -> install pd' lbi' copyFlags)
+  let registerFlags = defaultRegisterFlags {
+                          regDistPref  = installDistPref ifl,
+                          regInPlace   = installInPlace ifl,
+                          regPackageDB = installPackageDB ifl,
+                          regVerbosity = installVerbosity ifl
+                      }
+  when (hasLibs pd) $ register pd lbi registerFlags
+
+copy :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO ()
+copy pd lbi _uh cf =
+    xInstallTarget pd lbi (\pd' lbi' -> install pd' lbi' cf)
+
+xInstallTarget :: PackageDescription
+               -> LocalBuildInfo
+               -> (PackageDescription -> LocalBuildInfo -> IO ())
+               -> IO ()
+xInstallTarget pd lbi fn = do
+  let (extended, regular) = partition (isJust . installTarget) (executables pd)
+
+  let pd_regular = pd { executables = regular }
+
+  _ <- flip mapM extended $ \exe -> do
+    putStrLn $ "extended "  ++ show (exeName exe)
+
+    let
+        idirtpl          = installDirTemplates lbi
+        env              = installDirsTemplateEnv idirtpl
+        libexecdir'      = fromPathTemplate (libexecdir idirtpl)
+
+        pd_extended      = onlyExePackageDesc [exe] pd
+        install_target   = fromJust $ installTarget exe
+        install_target'  = ID.substPathTemplate env install_target
+        -- $libexec isn't a real thing :/ so we have to simulate it
+        install_target'' = substLibExec' libexecdir' install_target'
+
+    let lbi' = lbi {
+                 installDirTemplates =
+                     (installDirTemplates lbi) {
+                   bindir = install_target''
+                 }
+               }
+    fn pd_extended lbi'
+
+  fn pd_regular lbi
+
+ where
+   installTarget :: Executable -> Maybe PathTemplate
+   installTarget exe =
+    toPathTemplate <$> lookup "x-install-target" (customFieldsBI $ buildInfo exe)
+
+   substLibExec libexecdir "$libexecdir" = libexecdir
+   substLibExec _ comp = comp
+
+   substLibExec' dir =
+       withPT $
+           withSP $ map (substLibExec dir . dropTrailingPathSeparator)
+
+
+   withPT f pt = toPathTemplate $ f (fromPathTemplate pt)
+   withSP f p  = joinPath $ f (splitPath p)
+
+onlyExePackageDesc :: [Executable] -> PackageDescription -> PackageDescription
+onlyExePackageDesc exes pd = emptyPackageDescription {
+                     package = package pd
+                   , executables = exes
+                   }
+
+parseVer str =
+    case filter ((=="") . snd) $ readP_to_S parseVersion str of
+      [(ver, _)] -> ver
+      _ -> error $ "No parse (Ver) :(\n" ++ str ++ "\n"
+
+-- sanityCheckCabalVersions args cf desc lbi = do
+--   (cabalInstallVer, cabalVer) <- getCabalExecVer
+
+--   let
+--         ghcVer = compilerVersion (compiler lbi)
+--         -- ghc >= 7.10?
+--         minGhc710 = ghcVer `withinRange` orLaterVersion (parseVer "7.10")
+
+--   when minGhc710 $ do
+--     let cabalHelperCabalVer = compCabalVer (CExeName "cabal-helper")
+
+--     when (not $ cabalVer `sameMajorVersionAs` cabalHelperCabalVer) $
+--          failCabalVersionDifferent cabalVer cabalHelperCabalVer
+
+--   -- carry on as usual
+--   (postConf simpleUserHooks) args cf desc lbi
+
+--  where
+--    earlierVersionThan ver ver' =
+--        ver `withinRange` earlierVersion ver'
+--    sameMajorVersionAs ver ver' =
+--        ver `withinRange` withinVersion (Version (take 2 $ versionBranch ver') [])
+
+--    compCabalVer comp = let
+--        clbi = getComponentLocalBuildInfo lbi comp
+
+--        [cabalVer] =
+--            [ ver | (_, PackageIdentifier pkg ver) <- componentPackageDeps clbi
+--            , pkg == PackageName "Cabal" ]
+--      in cabalVer
+
+-- getCabalExecVer = do
+--   ["cabal-install", "version", cabalInstallVer, "using", "version", cabalVer, "of", "the", "Cabal", "library"] <- words <$> readProcess "cabal" ["--version"] ""
+--   return (parseVer cabalInstallVer, parseVer cabalVer)
+
+-- failCabalVersionDifferent cabalVer libCabalVer =
+--   putStrLn rerr  >> exitFailure
+--  where
+--    replace :: String -> String -> String -> String
+--    replace _ _ [] = []
+--    replace n r h@(h':hs)
+--        | map snd (n `zip` h ) == n = r ++ replace n r (drop (length n) h)
+--        | otherwise = h':replace n r hs
+
+--    rerr = replace "X.XX.X.X" (showVersion libCabalVer) $
+--           replace "Y.YY.Y.Y" (showVersion cabalVer) err
+--    err = "\
+-- \Error: Cabal seems to have decided ghc-mod should be built using Cabal\n\
+-- \X.XX.X.X while the `cabal' executable in your PATH was built with Cabal\n\
+-- \Y.YY.Y.Y. This will lead to conflicts when running ghc-mod in any project\n\
+-- \where you use this `cabal' executable. Please compile ghc-mod using the same\n\
+-- \Cabal version as your `cabal' executable or recompile cabal-install using\n\
+-- \this version of the Cabal library.\n\
+-- \\n\
+-- \See: https://github.com/kazu-yamamoto/ghc-mod/wiki/InconsistentCabalVersions\n"

SetupCompat.hs

@@ -0,0 +1,198 @@
+{-# LANGUAGE TemplateHaskell, RecordWildCards, StandaloneDeriving #-}
+module SetupCompat where
+
+import Control.Arrow
+import Control.Monad.Trans.State
+import Data.List
+import Data.Maybe
+import Data.Functor
+import Data.Function
+import Distribution.Simple.LocalBuildInfo
+import Distribution.PackageDescription
+
+import Distribution.Simple
+import Distribution.Simple.Setup
+import Distribution.Simple.Install
+
+import qualified Data.Map as M
+import Data.Map (Map)
+
+
+import NotCPP.Declarations
+import Language.Haskell.TH
+
+-- $(ifdefD "componentsConfigs" [d| deriving instance (Ord ComponentName) |] )
+
+$(ifD [d|
+
+ showComponentName :: ComponentName -> String
+ showComponentName CLibName          = "library"
+ showComponentName (CExeName   name) = "executable '" ++ name ++ "'"
+ showComponentName (CTestName  name) = "test suite '" ++ name ++ "'"
+ showComponentName (CBenchName name) = "benchmark '" ++ name ++ "'"
+
+ |])
+
+$(ifelsedefD "componentsConfigs" [d|
+
+ setComponentsConfigs
+    :: LocalBuildInfo
+    -> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])]
+    -> LocalBuildInfo
+ setComponentsConfigs lbi cs = $(recUpdE' (nE "lbi") (mkName "componentsConfigs") (VarE $ mkName "cs"))
+
+ |] [d|
+
+ setComponentsConfigs
+    :: LocalBuildInfo
+    -> [(ComponentName, ComponentLocalBuildInfo, a)]
+    -> LocalBuildInfo
+ setComponentsConfigs lbi cs = flip execState lbi $ mapM setClbis gcs
+  where
+   gcs = groupBy (sameKind `on` fst3) $ sortBy (compare `on` showComponentName . fst3) cs
+
+   fst3 (x,_,_) = x
+
+   sameKind CLibName CLibName = True
+   sameKind CLibName _ = False
+   sameKind (CExeName _) (CExeName _) = True
+   sameKind (CExeName _) _ = False
+   sameKind (CTestName _) (CTestName _) = True
+   sameKind (CTestName _) _ = False
+   sameKind (CBenchName _) (CBenchName _) = True
+   sameKind (CBenchName _) _ = False
+
+   setClbis [(CLibName, clbi, _)] =
+       get >>= \lbi ->
+           put $ $(recUpdE' (nE "lbi") (mkName "libraryConfig") (AppE (ConE (mkName "Just")) (VarE (mkName "clbi"))))
+
+   setClbis cs@((CExeName _, _, _):_) =
+       let cfg = (\((CExeName n), clbi, _) -> (n, clbi)) <$> cs in
+       get >>= \lbi ->
+           put $ $(recUpdE' (nE "lbi") (mkName "executableConfigs") (VarE $ mkName "cfg"))
+
+   setClbis cs@((CTestName _, _, _):_) =
+       let cfg = (\((CTestName n), clbi, _) -> (n, clbi)) <$> cs in
+       get >>= \lbi ->
+           put $ $(recUpdE' (nE "lbi") (mkName "testSuiteConfigs") (VarE $ mkName "cfg"))
+
+   setClbis cs@((CBenchName _, _, _):_) =
+       let cfg = (\((CBenchName n), clbi, _) -> (n, clbi)) <$> cs in
+       get >>= \lbi ->
+           put $ $(recUpdE' (nE "lbi") (mkName "benchmarkConfigs") (VarE $ mkName "cfg"))
+
+ |])
+
+
+$(ifD [d|
+
+ componentsConfigs ::
+    LocalBuildInfo -> [(ComponentName, ComponentLocalBuildInfo, [ComponentName])]
+ componentsConfigs LocalBuildInfo {..} =
+    (maybe [] (\c -> [(CLibName, c, [])]) $(nE "libraryConfig"))
+    ++ ((\(n, clbi) -> (CExeName n, clbi, [])) <$> $(nE "executableConfigs"))
+    ++ ((\(n, clbi) -> (CTestName n, clbi, [])) <$> $(nE "testSuiteConfigs"))
+    ++ ((\(n, clbi) -> (CBenchName n, clbi, [])) <$> $(nE "benchmarkConfigs"))
+
+ getComponent :: PackageDescription -> ComponentName -> Component
+ getComponent pkg cname =
+    case lookupComponent pkg cname of
+      Just cpnt -> cpnt
+      Nothing   -> missingComponent
+  where
+    missingComponent =
+      error $ "internal error: the package description contains no "
+           ++ "component corresponding to " ++ show cname
+
+ lookupComponent :: PackageDescription -> ComponentName -> Maybe Component
+ lookupComponent pkg CLibName =
+    fmap CLib $ library pkg
+ lookupComponent pkg (CExeName name) =
+    fmap CExe $ find ((name ==) . exeName) (executables pkg)
+ lookupComponent pkg (CTestName name) =
+    fmap CTest $ find ((name ==) . testName) (testSuites pkg)
+ lookupComponent pkg (CBenchName name) =
+    fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg)
+
+-- We're lying here can't be bothered to order these
+ allComponentsInBuildOrder :: LocalBuildInfo
+                          -> [(ComponentName, ComponentLocalBuildInfo)]
+ allComponentsInBuildOrder lbi =
+      [ (cname, clbi) | (cname, clbi, _) <- componentsConfigs lbi ]
+
+ getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo
+ getComponentLocalBuildInfo lbi cname =
+    case [ clbi
+         | (cname', clbi, _) <- componentsConfigs lbi
+         , cname == cname' ] of
+      [clbi] -> clbi
+      _      -> missingComponent
+  where
+    missingComponent =
+      error $ "internal error: there is no configuration data "
+           ++ "for component " ++ show cname
+
+ componentBuildInfo :: Component -> BuildInfo
+ componentBuildInfo =
+   foldComponent libBuildInfo buildInfo testBuildInfo benchmarkBuildInfo
+
+ |])
+
+
+$(ifelsedefD "componentPackageRenaming" [d|
+ -- M.Map PackageName
+ newtype Deps = Deps  { unDeps :: ([(InstalledPackageId, PackageId)], Map PackageName $(cT "ModuleRenaming")) }
+-- $(return $ TySynD $(mkName "Deps") [] [t| |] )
+
+ noDeps = Deps ([], M.empty)
+
+ getDeps :: ComponentLocalBuildInfo -> Deps
+ getDeps = componentPackageDeps &&& $(nE "componentPackageRenaming") >>> Deps
+
+ setUnionDeps :: Deps -> ComponentLocalBuildInfo -> ComponentLocalBuildInfo
+ setUnionDeps (Deps (deps, rns)) clbi = let
+         clbi' = setComponentPackageRenaming clbi rns
+         cpdeps = componentPackageDeps clbi
+       in
+         clbi' {
+           componentPackageDeps = cpdeps `union` deps
+         }
+
+ setComponentPackageRenaming clbi cprn =
+     -- [| clbi { componentPackageRenaming = componentPackageRenaming clbi `M.union` cprn } |]
+     $(recUpdE'
+       (nE "clbi")
+       (mkName "componentPackageRenaming")
+       (InfixE
+        (Just
+         (AppE
+          (VarE
+           (mkName "componentPackageRenaming"))
+          (VarE (mkName "clbi"))
+         ))
+        (VarE (mkName "M.union"))
+        (Just (VarE (mkName "cprn")))
+       )
+      )
+
+ |] [d|
+
+ newtype Deps = Deps { unDeps :: [(InstalledPackageId, PackageId)] }
+
+ noDeps = Deps []
+
+ getDeps :: ComponentLocalBuildInfo -> Deps
+ getDeps lbi = Deps $ componentPackageDeps lbi
+
+ setUnionDeps :: Deps -> ComponentLocalBuildInfo -> ComponentLocalBuildInfo
+ setUnionDeps (Deps deps) clbi = let
+         cpdeps = componentPackageDeps clbi
+       in
+         clbi {
+           componentPackageDeps = cpdeps `union` deps
+         }
+
+
+-- setComponentPackageRenaming clbi _cprn = clbi
+
+ |])

Utils.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE CPP #-}
+module Utils where
+
+import Control.Applicative
+import Data.Traversable
+import System.Directory
+
+#if MIN_VERSION_directory(1,2,0)
+import Data.Time (UTCTime)
+#else
+import System.Time (ClockTime)
+#endif
+import Prelude
+
+
+#if MIN_VERSION_directory(1,2,0)
+type ModTime = UTCTime
+#else
+type ModTime = ClockTime
+#endif
+
+data TimedFile = TimedFile { tfPath :: FilePath, tfTime :: ModTime }
+                 deriving (Eq, Show)
+
+instance Ord TimedFile where
+    compare (TimedFile _ a) (TimedFile _ b) = compare a b
+
+timeFile :: FilePath -> IO TimedFile
+timeFile f = TimedFile <$> pure f <*> getModificationTime f
+
+mightExist :: FilePath -> IO (Maybe FilePath)
+mightExist f = do
+  exists <- doesFileExist f
+  return $ if exists then (Just f) else (Nothing)
+
+timeMaybe :: FilePath -> IO (Maybe TimedFile)
+timeMaybe f = traverse timeFile =<< mightExist f

doc/emacs.piki

@@ -119,7 +119,7 @@ foo xs = foldr bar id xs
     bar = (:)
 |<
 
-C-xC-s highlights the 2nd line. C-c? displays the following:
+C-xC-s highlights the 2nd line. M-? displays the following:
 
 >|
 Couldn't match type `[a -> a]' with `a -> a'
@@ -139,7 +139,7 @@ foo xs = foldr _bar id xs
     bar = (:)
 |<
 
-C-c? displays:
+M-? displays:
 
 >|
 Found hole `_bar' with type: (a -> a) -> (a -> a) -> a -> a

elisp/ghc-check.el

@@ -20,7 +20,7 @@
      :underline (:style wave :color "orangered"))
     (t
      :inherit error))
-  "Face used for marking error lines."
+  "Face used for error lines."
   :group 'ghc)
 
 (defface ghc-face-warn
@@ -28,7 +28,7 @@
      :underline (:style wave :color "gold"))
     (t
      :inherit warning))
-  "Face used for marking warning lines."
+  "Face used for warning lines."
   :group 'ghc)
 
 (defface ghc-face-hole
@@ -36,7 +36,7 @@
      :underline (:style wave :color "purple"))
     (t
      :inherit warning))
-  "Face used for marking hole lines."
+  "Face used for hole lines."
   :group 'ghc)
 
 (defvar ghc-check-error-fringe (propertize "!" 'display '(left-fringe exclamation-mark)))
@@ -46,27 +46,34 @@
 (defvar ghc-check-hole-fringe (propertize "_" 'display '(left-fringe horizontal-bar)))
 
 (defvar ghc-display-error nil
-  "*An action to display errors/warnings for 'M-n' and 'M-p:
+  "*How to display errors/warnings when using 'M-n' and 'M-p':
 
-nil            does not display errors/warnings.
+nil            do not display errors/warnings.
-'minibuffer    displays errors/warnings in the minibuffer.
+'minibuffer    display errors/warnings in the minibuffer.
-'other-buffer  displays errors/warnings in the other buffer.
+'other-buffer  display errors/warnings in a new buffer.
 ")
 
 (defvar ghc-display-hole 'other-buffer
-  "*An action to display hole information for 'C-c C-j' and 'C-c C-h'
+  "*How to display hole information when using 'C-c C-j' and 'C-c C-h'
 
-'minibuffer    displays errors/warnings in the minibuffer.
+'minibuffer    display errors/warnings in the minibuffer.
-'other-buffer  displays errors/warnings in the other buffer"
+'other-buffer  display errors/warnings in the a new buffer"
 )
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defun ghc-check-syntax ()
   (interactive)
+  ;; Only check syntax of visible buffers
+  (when (and (buffer-file-name)
+	     (file-exists-p (buffer-file-name))
+	     (get-buffer-window (current-buffer) t))
+    (with-timeout
+        (10 (error "ghc process may have hung or exited with an error"))
+      (while ghc-process-running (sleep-for 0.1)))
     (ghc-with-process (ghc-check-send)
                       'ghc-check-callback
-		    (lambda () (setq mode-line-process " -:-"))))
+                      (lambda () (setq mode-line-process " -:-")))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -132,7 +139,7 @@ nil            does not display errors/warnings.
 	info infos)
     (dolist (err errs (nreverse infos))
       (when (string-match regex err)
-	(let* ((file (expand-file-name (match-string 1 err))) ;; for Windows
+	(let* ((file (expand-file-name (match-string 1 err) ghc-process-root)) ;; for Windows
 	       (line (string-to-number (match-string 2 err)))
                (coln (string-to-number (match-string 3 err)))
 	       (msg (match-string 4 err))
@@ -167,18 +174,20 @@ nil            does not display errors/warnings.
 	  ;; If this is a bottleneck for a large code, let's fix.
 	  (goto-char (point-min))
 	  (cond
-           ((and (string= ofile file) hole)
+	   ((string= (file-truename ofile) (file-truename file))
+            (if hole
+              (progn
                 (forward-line (1- line))
                 (forward-char (1- coln))
                 (setq beg (point))
                 (forward-char (length hole))
                 (setq end (point)))
-	   ((string= ofile file)
+              (progn
                 (forward-line (1- line))
-	    (while (eq (char-after) 32) (forward-char))
+                (forward-char (1- coln))
                 (setq beg (point))
-	    (forward-line)
+                (skip-chars-forward "^[:space:]" (line-end-position))
-	    (setq end (1- (point))))
+                (setq end (point)))))
 	   (t
 	    (setq beg (point))
 	    (forward-line)

elisp/ghc-doc.el

@@ -25,7 +25,7 @@
     (setq pkg-ver-path (and mod (ghc-resolve-document-path mod)))
     (if pkg-ver-path
 	(ghc-display-document pkg-ver-path mod haskell-org expr)
-      (message "No document found"))))
+      (message "No documentation found"))))
 
 (ghc-defstruct pkg-ver-path pkg ver path)
 
@@ -93,7 +93,7 @@
   (read-from-minibuffer "Module name: " def ghc-input-map))
 
 (defun ghc-read-expression (def)
-  (read-from-minibuffer "Expression: " def ghc-input-map))
+  (read-from-minibuffer "Identifier: " def ghc-input-map))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 

elisp/ghc-func.el

@@ -182,9 +182,19 @@
         (funcall ins-func)
         (goto-char (point-min))
         (if (not fontify)
+            ;; turn-off-haskell-font-lock has been removed from haskell-mode
+            ;; test if the function is defined in our version
+            (if (fboundp 'turn-off-haskell-font-lock)
                 (turn-off-haskell-font-lock)
+              ;; it's not defined, fallback on font-lock-mode
+              (font-lock-mode -1))
           (haskell-font-lock-defaults-create)
-          (turn-on-haskell-font-lock)))
+          ;; turn-on-haskell-font-lock has been removed from haskell-mode
+          ;; test if the function is defined in our version
+          (if (fboundp 'turn-on-haskell-font-lock)
+              (turn-on-haskell-font-lock)
+            ;; it's not defined, fallback on font-lock-mode
+            (turn-on-font-lock))))
       (display-buffer buf
         '((display-buffer-reuse-window
            display-buffer-pop-up-window))))))

elisp/ghc-info.el

@@ -82,7 +82,7 @@
     (if (null tinfos)
 	(progn
 	  (ghc-type-clear-overlay)
-	  (message "Cannot guess type"))
+	  (message "Cannot determine type"))
       (let* ((tinfo (nth (ghc-type-get-ix) tinfos))
 	     (type (ghc-tinfo-get-info tinfo))
 	     (beg-line (ghc-tinfo-get-beg-line tinfo))
@@ -127,7 +127,7 @@
 (defun ghc-expand-th ()
   (interactive)
   (let* ((file (buffer-file-name))
-	 (cmds (list "expand" file))
+	 (cmds (list "-b" "\n" "expand" file))
 	 (source (ghc-run-ghc-mod cmds)))
     (when source
       (ghc-display

elisp/ghc-pkg.el

@@ -2,4 +2,4 @@
   "ghc"
   2.0.0
   "Sub mode for Haskell mode"
-  nil)
+  '((haskell-mode "13.0")))

elisp/ghc-process.el

@@ -10,6 +10,9 @@
 
 (require 'ghc-func)
 
+(defvar ghc-debug-options nil)
+;; (setq ghc-debug-options '("-v9"))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defvar ghc-process-running nil)
@@ -19,8 +22,11 @@
 (defvar-local ghc-process-original-file nil)
 (defvar-local ghc-process-callback nil)
 (defvar-local ghc-process-hook nil)
+(defvar-local ghc-process-root nil)
 
-(defvar ghc-interactive-command "ghc-modi")
+(defvar ghc-command "ghc-mod")
+
+(defvar ghc-error-buffer "*GHC Error*")
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -28,14 +34,15 @@
   (ghc-run-ghc-mod '("root")))
 
 (defun ghc-with-process (cmd callback &optional hook1 hook2)
+  (let ((root (ghc-get-project-root)))
     (unless ghc-process-process-name
-    (setq ghc-process-process-name (ghc-get-project-root)))
+      (setq ghc-process-process-name root))
     (when (and ghc-process-process-name (not ghc-process-running))
       (setq ghc-process-running t)
       (if hook1 (funcall hook1))
       (let* ((cbuf (current-buffer))
 	     (name ghc-process-process-name)
-	   (buf (get-buffer-create (concat " ghc-modi:" name)))
+	     (buf (get-buffer-create (concat " ghc-mod:" name)))
 	     (file (buffer-file-name))
 	     (cpro (get-process name)))
 	(ghc-with-current-buffer buf
@@ -43,13 +50,14 @@
 	  (setq ghc-process-original-file file)
 	  (setq ghc-process-callback callback)
 	  (setq ghc-process-hook hook2)
+	  (setq ghc-process-root root)
 	  (erase-buffer)
 	  (let ((pro (ghc-get-process cpro name buf)))
 	    (process-send-string pro cmd)
 	    (when ghc-debug
 	      (ghc-with-debug-buffer
 	       (insert (format "%% %s" cmd))))
-	  pro)))))
+	    pro))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -63,37 +71,74 @@
    (t cpro)))
 
 (defun ghc-start-process (name buf)
-  (let* ((opts (append '("-b" "\n" "-l") (ghc-make-ghc-options)))
+  (let* ((opts (append ghc-debug-options
-	 (pro (apply 'start-file-process name buf ghc-interactive-command opts)))
+		       '("-b" "\n" "-l" "--line-prefix=O: ,E: ")
+		       (ghc-make-ghc-options)
+		       '("legacy-interactive")))
+	 (pro (apply 'start-file-process name buf ghc-command opts)))
     (set-process-filter pro 'ghc-process-filter)
     (set-process-sentinel pro 'ghc-process-sentinel)
     (set-process-query-on-exit-flag pro nil)
     pro))
 
 (defun ghc-process-filter (process string)
-  (let ((pbuf (process-buffer process)))
+  (let* ((pbuf (process-buffer process))
+	 (tbufname (concat " tmp " (buffer-name pbuf)))
+	 tbuf)
     (if (not (get-buffer pbuf))
 	(setq ghc-process-running nil) ;; just in case
-      (ghc-with-current-buffer (process-buffer process)
+      (ghc-with-current-buffer pbuf
+	(when ghc-debug
+	  (ghc-with-debug-buffer
+	   (insert string)))
+	(with-current-buffer (get-buffer-create tbufname)
+	  (setq tbuf (current-buffer))
 	  (goto-char (point-max))
 	  (insert string)
+	  (goto-char (point-min))
+	  (let ((cont t) end out)
+	    (while (and cont (not (eobp)))
+	      (cond
+	       ((looking-at "^O: ")
+		(setq out t))
+	       ((looking-at "^E: ")
+		(setq out nil))
+	       (t
+		(setq cont nil)))
+	      (when cont
+		(forward-line)
+		(unless (bolp) (setq cont nil)))
+	      (when cont
+		(delete-region 1 4)
+		(setq end (point))
+		(if out
+		    (with-current-buffer pbuf
+		      (goto-char (point-max))
+		      (insert-buffer-substring tbuf 1 end))
+		  (with-current-buffer (get-buffer-create ghc-error-buffer)
+		    (setq buffer-read-only t)
+		    (let* ((buffer-read-only nil)
+			   (inhibit-read-only t)
+			   (cbuf (current-buffer))
+			   cwin)
+		      (unless (get-buffer-window cbuf) (display-buffer cbuf))
+		      (setq cwin (get-buffer-window cbuf))
+		      (with-selected-window cwin
+			(goto-char (point-max))
+			(insert-buffer-substring tbuf 1 end)
+			(set-buffer-modified-p nil)
+			(redisplay)))))
+		(delete-region 1 end)))))
+	(goto-char (point-max))
 	(forward-line -1)
 	(cond
 	 ((looking-at "^OK$")
 	  (if ghc-process-hook (funcall ghc-process-hook))
 	  (goto-char (point-min))
 	  (funcall ghc-process-callback 'ok)
-	  (when ghc-debug
-	    (let ((cbuf (current-buffer)))
-	      (ghc-with-debug-buffer
-	       (insert-buffer-substring cbuf))))
 	  (setq ghc-process-running nil))
 	 ((looking-at "^NG ")
 	  (funcall ghc-process-callback 'ng)
-	  (when ghc-debug
-	    (let ((cbuf (current-buffer)))
-	      (ghc-with-debug-buffer
-	       (insert-buffer-substring cbuf))))
 	  (setq ghc-process-running nil)))))))
 
 (defun ghc-process-sentinel (process event)

elisp/ghc.el

@@ -28,7 +28,7 @@
 	       (< emacs-minor-version minor)))
       (error "ghc-mod requires at least Emacs %d.%d" major minor)))
 
-(defconst ghc-version "5.2.1.2")
+(defconst ghc-version "5.3.0.0")
 
 ;; (eval-when-compile
 ;;  (require 'haskell-mode))
@@ -117,6 +117,9 @@
     (setq ghc-initialized t)
     (defadvice save-buffer (after ghc-check-syntax-on-save activate)
       "Check syntax with GHC when a haskell-mode buffer is saved."
+      (when (eq 'haskell-mode major-mode) (ghc-check-syntax)))
+    (defadvice switch-to-buffer (after ghc-check-syntax-on-switch-to-buffer activate)
+      "Check syntax with GHC when switching to a haskell-mode buffer."
       (when (eq 'haskell-mode major-mode) (ghc-check-syntax))))
   (ghc-import-module)
   (ghc-check-syntax))
@@ -130,23 +133,19 @@
   (let ((el-path (locate-file "ghc.el" load-path))
 	(ghc-path (executable-find "ghc")) ;; FIXME
 	(ghc-mod-path (executable-find ghc-module-command))
-	(ghc-modi-path (executable-find ghc-interactive-command))
 	(el-ver ghc-version)
 	(ghc-ver (ghc-run-ghc-mod '("--version") "ghc"))
 	(ghc-mod-ver (ghc-run-ghc-mod '("version")))
-	(ghc-modi-ver (ghc-run-ghc-mod '("version") ghc-interactive-command))
 	(path (getenv "PATH")))
     (switch-to-buffer (get-buffer-create "**GHC Debug**"))
     (erase-buffer)
     (insert "Path: check if you are using intended programs.\n")
     (insert (format "\t  ghc.el path: %s\n" el-path))
     (insert (format "\t ghc-mod path: %s\n" ghc-mod-path))
-    (insert (format "\tghc-modi path: %s\n" ghc-modi-path))
     (insert (format "\t     ghc path: %s\n" ghc-path))
-    (insert "\nVersion: all versions must be the same.\n")
+    (insert "\nVersion: all GHC versions must be the same.\n")
     (insert (format "\t  ghc.el version %s\n" el-ver))
     (insert (format "\t %s\n" ghc-mod-ver))
-    (insert (format "\t%s\n" ghc-modi-ver))
     (insert (format "\t%s\n" ghc-ver))
     (insert "\nEnvironment variables:\n")
     (insert (format "\tPATH=%s\n" path))))

ghc-mod.cabal

@@ -1,73 +1,102 @@
 Name:                   ghc-mod
-Version:                5.2.1.2
+Version:                5.3.0.0
-Author:                 Kazu Yamamoto <kazu@iij.ad.jp>
+Author:                 Kazu Yamamoto <kazu@iij.ad.jp>,
-                        Daniel Gröber <dxld@darkboxed.org>
+                        Daniel Gröber <dxld@darkboxed.org>,
                         Alejandro Serrano <trupill@gmail.com>
-Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp>
+Maintainer:             Daniel Gröber <dxld@darkboxed.org>
-License:                BSD3
+License:                AGPL-3
 License-File:           LICENSE
+License-Files:          COPYING.BSD3 COPYING.AGPL3
 Homepage:               http://www.mew.org/~kazu/proj/ghc-mod/
 Synopsis:               Happy Haskell Programming
-Description:            The ghc-mod command is a backend command to enrich
+Description:
-                        Haskell programming on editors including
+  ghc-mod is a backend program to enrich Haskell programming in editors. It
-                        Emacs, Vim, and Sublime.
+  strives to offer most of the features one has come to expect from modern IDEs
-                        The ghc-mod command is based on ghc-mod library
+  in any editor.
-                        which is a wrapper of GHC API.
+
-                        This package includes the ghc-mod command,
+  ghc-mod provides a library for other haskell programs to use as well as a
-                        the ghc-mod library, and Emacs front-end
+  standalone program for easy editor integration. All of the fundamental
-                        (for historical reasons).
+  functionality of the frontend program can be accessed through the library
+  however many implementation details are hidden and if you want to
+  significantly extend ghc-mod you should submit these changes upstream instead
+  of implementing them on top of the library.
+
   For more information, please see its home page.
 
-Category:               Development
+Category:               GHC, Development
-Cabal-Version:          >= 1.10
+Cabal-Version:          >= 1.14
-Build-Type:             Simple
+Build-Type:             Custom
-Data-Dir:               elisp
+Data-Files:             elisp/Makefile
-Data-Files:             Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el
+                        elisp/*.el
-                        ghc-check.el ghc-process.el ghc-command.el ghc-info.el
+Data-Files:             LICENSE COPYING.BSD3 COPYING.AGPL3
-                        ghc-ins-mod.el ghc-indent.el ghc-pkg.el ghc-rewrite.el
 Extra-Source-Files:     ChangeLog
-			test/data/*.cabal
+                        SetupCompat.hs
-                        test/data/*.hs
+                        NotCPP/*.hs
-                        test/data/cabal.sandbox.config.in
+                        test/data/annotations/*.hs
-                        test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf
                         test/data/broken-cabal/*.cabal
                         test/data/broken-cabal/cabal.sandbox.config.in
-                        test/data/broken-sandbox/*.cabal
                         test/data/broken-sandbox/cabal.sandbox.config
+                        test/data/broken-sandbox/dummy.cabal
+                        test/data/cabal-flags/cabal-flags.cabal
+                        test/data/cabal-project/*.cabal
+                        test/data/cabal-project/*.hs
+                        test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf
+                        test/data/cabal-project/cabal.sandbox.config.in
+                        test/data/cabal-project/subdir1/subdir2/dummy
                         test/data/case-split/*.hs
-                        test/data/cabal-flags/*.cabal
+                        test/data/check-packageid/cabal.sandbox.config.in
+                        test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf
                         test/data/check-test-subdir/*.cabal
                         test/data/check-test-subdir/src/Check/Test/*.hs
                         test/data/check-test-subdir/test/*.hs
                         test/data/check-test-subdir/test/Bar/*.hs
-                        test/data/check-packageid/cabal.sandbox.config.in
-                        test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf
                         test/data/duplicate-pkgver/cabal.sandbox.config.in
                         test/data/duplicate-pkgver/duplicate-pkgver.cabal
                         test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-1.0-7c59d13f32294d1ef6dc6233c24df961.conf
                         test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-14e543bdae2da4d2aeff5386892c9112.conf
                         test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf
-                        test/data/pattern-synonyms/*.cabal
+                        test/data/foreign-export/*.hs
-                        test/data/pattern-synonyms/*.hs
                         test/data/ghc-mod-check/*.cabal
                         test/data/ghc-mod-check/*.hs
-                        test/data/ghc-mod-check/Data/*.hs
+                        test/data/ghc-mod-check/lib/Data/*.hs
-                        test/data/subdir1/subdir2/dummy
+                        test/data/hlint/*.hs
-                        test/data/.cabal-sandbox/packages/00-index.tar
+                        test/data/home-module-graph/cpp/*.hs
+                        test/data/home-module-graph/cycle/*.hs
+                        test/data/home-module-graph/errors/*.hs
+                        test/data/home-module-graph/indirect/*.hs
+                        test/data/home-module-graph/indirect-update/*.hs
+                        test/data/import-cycle/*.hs
+                        test/data/non-exported/*.hs
+                        test/data/pattern-synonyms/*.cabal
+                        test/data/pattern-synonyms/*.hs
+                        test/data/quasi-quotes/*.hs
+                        test/data/template-haskell/*.hs
+                        test/data/target/*.hs
+                        test/data/check-missing-warnings/*.hs
+                        test/data/custom-cradle/custom-cradle.cabal
+                        test/data/custom-cradle/ghc-mod.package-db-stack
+                        test/data/custom-cradle/package-db-a/.gitkeep
+                        test/data/custom-cradle/package-db-b/.gitkeep
+                        test/data/custom-cradle/package-db-c/.gitkeep
+                        test/data/cabal-preprocessors/*.cabal
+                        test/data/cabal-preprocessors/*.hs
+                        test/data/cabal-preprocessors/*.hsc
 
 Library
   Default-Language:     Haskell2010
-  GHC-Options:          -Wall
+  GHC-Options:          -Wall -fno-warn-deprecations
-  Default-Extensions:   ConstraintKinds, FlexibleContexts
+  Default-Extensions:   ScopedTypeVariables, RecordWildCards, NamedFieldPuns,
+                        ConstraintKinds, FlexibleContexts,
+                        DataKinds, KindSignatures, TypeOperators
   Exposed-Modules:      Language.Haskell.GhcMod
                         Language.Haskell.GhcMod.Internal
-  Other-Modules:        Language.Haskell.GhcMod.Boot
+  Other-Modules:        Paths_ghc_mod
+                        Utils
+                        Language.Haskell.GhcMod.Boot
                         Language.Haskell.GhcMod.Browse
-                        Language.Haskell.GhcMod.Cabal16
+                        Language.Haskell.GhcMod.CabalHelper
-                        Language.Haskell.GhcMod.Cabal18
+                        Language.Haskell.GhcMod.Caching
-                        Language.Haskell.GhcMod.Cabal21
+                        Language.Haskell.GhcMod.Caching.Types
-                        Language.Haskell.GhcMod.CabalApi
-                        Language.Haskell.GhcMod.CabalConfig
                         Language.Haskell.GhcMod.CaseSplit
                         Language.Haskell.GhcMod.Check
                         Language.Haskell.GhcMod.Convert
@@ -79,18 +108,21 @@ Library
                         Language.Haskell.GhcMod.FillSig
                         Language.Haskell.GhcMod.Find
                         Language.Haskell.GhcMod.Flag
-                        Language.Haskell.GhcMod.GHCApi
-                        Language.Haskell.GhcMod.GHCChoice
                         Language.Haskell.GhcMod.Gap
                         Language.Haskell.GhcMod.GhcPkg
+                        Language.Haskell.GhcMod.HomeModuleGraph
                         Language.Haskell.GhcMod.Info
                         Language.Haskell.GhcMod.Lang
                         Language.Haskell.GhcMod.Lint
                         Language.Haskell.GhcMod.Logger
+                        Language.Haskell.GhcMod.Logging
                         Language.Haskell.GhcMod.Modules
                         Language.Haskell.GhcMod.Monad
+                        Language.Haskell.GhcMod.Monad.Types
+                        Language.Haskell.GhcMod.Output
                         Language.Haskell.GhcMod.PathsAndFiles
                         Language.Haskell.GhcMod.PkgDoc
+                        Language.Haskell.GhcMod.Pretty
                         Language.Haskell.GhcMod.Read
                         Language.Haskell.GhcMod.SrcUtils
                         Language.Haskell.GhcMod.Target
@@ -98,7 +130,10 @@ Library
                         Language.Haskell.GhcMod.Utils
                         Language.Haskell.GhcMod.World
   Build-Depends:        base >= 4.0 && < 5
+                      , bytestring
+                      , cereal >= 0.4
                       , containers
+                      , cabal-helper == 0.5.* && >= 0.5.1.0
                       , deepseq
                       , directory
                       , filepath
@@ -106,7 +141,6 @@ Library
                       , ghc-paths
                       , ghc-syb-utils
                       , hlint >= 1.8.61
-                      , io-choice
                       , monad-journal >= 0.4
                       , old-time
                       , pretty
@@ -117,30 +151,28 @@ Library
                       , transformers
                       , transformers-base
                       , mtl >= 2.0
-                      , monad-control
+                      , monad-control >= 1
                       , split
                       , haskell-src-exts
                       , text
                       , djinn-ghc >= 0.0.2.2
-  if impl(ghc >= 7.8)
+                      , fclabels
-    Build-Depends:      Cabal >= 1.18
+  if impl(ghc < 7.8)
-  else
     Build-Depends:      convertible
-                      , Cabal >= 1.10 && < 1.17
+  if impl(ghc < 7.5)
-  if impl(ghc <= 7.4.2)
     -- Only used to constrain random to a version that still works with GHC 7.4
-    Build-Depends:      random <= 1.0.1.1
+    Build-Depends:      random <= 1.0.1.1,
+                        ghc-prim
 
 Executable ghc-mod
   Default-Language:     Haskell2010
   Main-Is:              GHCMod.hs
   Other-Modules:        Paths_ghc_mod
-  GHC-Options:          -Wall
+  GHC-Options:          -Wall -fno-warn-deprecations
   Default-Extensions:   ConstraintKinds, FlexibleContexts
   HS-Source-Dirs:       src
   Build-Depends:        base >= 4.0 && < 5
                       , async
-                      , data-default
                       , directory
                       , filepath
                       , pretty
@@ -156,22 +188,17 @@ Executable ghc-modi
   Other-Modules:        Paths_ghc_mod
                         Misc
                         Utils
-  GHC-Options:          -Wall -threaded
+  GHC-Options:          -Wall -threaded -fno-warn-deprecations
   if os(windows)
       Cpp-Options:      -DWINDOWS
   Default-Extensions:   ConstraintKinds, FlexibleContexts
-  HS-Source-Dirs:       src
+  HS-Source-Dirs:       src, .
   Build-Depends:        base >= 4.0 && < 5
-                      , async
-                      , containers
                       , directory
                       , filepath
-                      , old-time
                       , process
-                      , split
                       , time
-                      , ghc
+                      , old-time
-                      , ghc-mod
 
 Test-Suite doctest
   Type:                 exitcode-stdio-1.0
@@ -180,20 +207,27 @@ Test-Suite doctest
   Ghc-Options:          -Wall
   Default-Extensions:   ConstraintKinds, FlexibleContexts
   Main-Is:              doctests.hs
+  if impl(ghc == 7.4.*)
+    Buildable:          False
   Build-Depends:        base
                       , doctest >= 0.9.3
 
 Test-Suite spec
   Default-Language:     Haskell2010
-  Default-Extensions:   ConstraintKinds, FlexibleContexts
+  Default-Extensions:   ScopedTypeVariables, RecordWildCards, NamedFieldPuns,
+                        ConstraintKinds, FlexibleContexts,
+                        DataKinds, KindSignatures, TypeOperators
   Main-Is:              Main.hs
   Hs-Source-Dirs:       test, .
-  Ghc-Options:          -Wall
+  Ghc-Options:          -Wall -fno-warn-deprecations
+  CPP-Options:          -DSPEC=1
   Type:                 exitcode-stdio-1.0
-  Other-Modules:        BrowseSpec
+  Other-Modules:        Paths_ghc_mod
-                        CabalApiSpec
-                        CheckSpec
                         Dir
+                        Spec
+                        TestUtils
+                        BrowseSpec
+                        CheckSpec
                         FlagSpec
                         InfoSpec
                         LangSpec
@@ -201,42 +235,14 @@ Test-Suite spec
                         ListSpec
                         MonadSpec
                         PathsAndFilesSpec
-                        Spec
+                        HomeModuleGraphSpec
-                        TestUtils
+
-  Build-Depends:        base >= 4.0 && < 5
+  Build-Depends:        hspec >= 2.0.0
-                      , containers
+  if impl(ghc == 7.4.*)
-                      , deepseq
-                      , directory
-                      , filepath
-                      , ghc
-                      , ghc-paths
-                      , ghc-syb-utils
-                      , hlint >= 1.7.1
-                      , io-choice
-                      , monad-journal >= 0.4
-                      , old-time
-                      , pretty
-                      , process
-                      , syb
-                      , temporary
-                      , time
-                      , transformers
-                      , transformers-base
-                      , mtl >= 2.0
-                      , monad-control
-                      , hspec >= 1.8.2
-                      , split
-                      , haskell-src-exts
-                      , text
-                      , djinn-ghc >= 0.0.2.2
-  if impl(ghc >= 7.8)
-    Build-Depends:      Cabal >= 1.18
-  else
-    Build-Depends:      convertible
-                      , Cabal >= 1.10 && < 1.17
-  if impl(ghc < 7.6)
     Build-Depends:     executable-path
-  CPP-Options:        -DSPEC=1
+  X-Build-Depends-Like: CLibName
+
+
 
 Source-Repository head
   Type:                 git

ghcmodHappyHaskellProgram-Dg.tex

@@ -0,0 +1,51 @@
+% ghcmodHappyHaskellProgram-Dg.tex
+\begin{hcarentry}[updated]{ghc-mod --- Happy Haskell Programming}
+\report{Daniel Gr\"ober}%05/15
+\status{open source, actively developed}
+\makeheader
+
+\texttt{ghc-mod} is both a backend program for enhancing editors and other kinds
+of development environments with support for Haskell, and an Emacs package
+providing the user facing functionality, internally called \texttt{ghc} for
+historical reasons. Other people have also developed numerous front ends for Vim
+and there also exist some for Atom and a few other proprietary editors.
+
+After a period of declining activity, development has been picking up pace again
+since Daniel Gr\"ober took over as maintainer. Most changes during versions
+5.0.0--5.2.1.2 consisted only of fixes and internal cleanup work, but for the
+past four months, vastly improved Cabal support has been in the works and is now
+starting to stabilize.
+
+This work is a major step forward in terms of how well ghc-mod's suggestions
+reflect what \texttt{cabal build} would report, and should also allow ghc-mod's
+other features to work even in more complicated Cabal setups.
+
+Daniel Gr\"ober has been accepted for a summer internship at IIJ Innovation
+Institute's Research Laboratory working on \texttt{ghc-mod} for two months
+(August--September). He will be working on:
+\begin{compactitem}
+
+  \item adding GHCi-like interactive code execution, to bring \texttt{ghc-mod} up
+    to feature parity with GHCi and beyond,
+
+  \item investigating how to best cooperate with \texttt{ide-backend},
+
+  \item adding a network interface to make using ghc-mod in other projects
+    easier, and
+
+  \item if time allows, cleaning up the Emacs frontend to be more user-friendly
+    and in line with Emacs' conventions.
+\end{compactitem}
+
+The goal of this work is to make \texttt{ghc-mod} the obvious choice for anyone
+implementing Haskell support for a development environment and improving
+\texttt{ghc-mod}'s overall feature set and reliability in order to give new as
+well as experienced Haskell developers the best possible experience.
+
+Right now \texttt{ghc-mod} has only one core developer and only a handful of
+occasional drive-by contributors. If \textit{you} want to help make Haskell
+development even more fun come and join us!
+
+\FurtherReading
+  \url{https://github.com/kazu-yamamoto/ghc-mod}
+\end{hcarentry}

hcar-ghc-mod.tex

@@ -1,26 +0,0 @@
-% ghcmodHappyHaskellProgram-Kg.tex
-\begin{hcarentry}[updated]{ghc-mod --- Happy Haskell Programming}
-\report{Kazu Yamamoto}%11/14
-\status{open source, actively developed}
-\makeheader
-
-For a long time, Kazu Yamamoto was the only active developer of ghc-mod, now two
-new developers have joined:
-
-Alejandro Serrano merged the results of his Google Summer of Code project. He
-implemented case splitting and sophisticated typed hole handling.  Daniel Gröber
-brushed up the internal code and introduced the GhcModT monad now used
-throughout the exported API. As a result the API of \texttt{ghc-mod} drastically
-changed with version 5.0.0.
-
-\texttt{ghc-modi} used to suffer from various consistency related issues
-triggered by changes in the environment, for instance: changing file names of
-modules, adding dependencies to the cabal file and installing new libraries.
-\texttt{ghc-modi} v5.1.1 or later handles changes in the environment by
-restarting the GHC session when this is detected.
-
-Kazu stepped down as release manager and Daniel took over.
-
-\FurtherReading
-  \url{http://www.mew.org/~kazu/proj/ghc-mod/en/}
-\end{hcarentry}

scripts/bump.sh

@@ -1,5 +1,7 @@
 #!/bin/sh
 
+set -e
+
 if [ -z "$1" ]; then
     echo "Usage: $0 VERSION" >&2
     exit 1
@@ -19,6 +21,13 @@ sed -i 's/(defconst ghc-version ".*")/(defconst ghc-version "'"$VERSION"'")/' \
 
 sed -r -i 's/^(Version:[[:space:]]*)[0-9.]+/\1'"$VERSION"'/' ghc-mod.cabal
 
+git add elisp/ghc.el ghc-mod.cabal
+git commit -m "Bump version to $VERSION"
+
+git checkout release
+#git merge master
+git merge -s recursive -X theirs master
+
 ( tac ChangeLog; echo "\n$(date '+%Y-%m-%d') v$VERSION" ) | tac \
     > ChangeLog.tmp
 
@@ -26,6 +35,8 @@ mv ChangeLog.tmp ChangeLog
 
 emacs -q -nw ChangeLog
 
-git add ChangeLog elisp/ghc.el ghc-mod.cabal
+git add ChangeLog
-git commit -m "Bump version to $VERSION"
+git commit -m "ChangeLog"
+
+
 git tag "v$VERSION"

scripts/compare-versions.sh

@@ -0,0 +1,36 @@
+################################################################################
+#                                                                              #
+# Find version differences in common packages of `ghc-pkg list` dumps.         #
+#                                                                              #
+# Copyright (C)  2015  Daniel Gröber <dxld@darkboxed.org>                      #
+#                                                                              #
+# Copying and distribution of this file, with or without modification,         #
+# are permitted in any medium without royalty provided the copyright           #
+# notice and this notice are preserved.  This file is offered as-is,           #
+# without any warranty.                                                        #
+#                                                                              #
+# Usage: sh compare-versions.sh FILE1 FILE2                                    #
+#                                                                              #
+# Example:                                                                     #
+#     sh compare-versions.sh =(ghc-pkg list) =(ssh some-host ghc-pkg list)     #
+#                                                                              #
+#   Where `=(command)` is equivalent to:                                       #
+#     `(tmp=$(mktemp); command > $tmp; echo $tmp)`                             #
+#                                                                              #
+#                                                                              #
+# The output consists of lines in the format:                                  #
+#    <PKG> <VERSION1> <VERSION2>                                               #
+# VERSION1 is the version from FILE1 and VERSION2 is the version from FILE2    #
+#                                                                              #
+################################################################################
+
+t1=$(mktemp)
+t2=$(mktemp)
+
+grep "^ " "$1" | sed 's/ *\(.*\)-\([0-9.]\+\)/\1 \2/' | sort > $t1
+grep "^ " "$2" | sed 's/ *\(.*\)-\([0-9.]\+\)/\1 \2/' | sort > $t2
+
+comm -3 -2 $t1 $t2 | sort -k 1b,1 > $t1.diff
+comm -3 -1 $t1 $t2 | sort -k 1b,1 > $t2.diff
+
+join $t1.diff $t2.diff | sort | uniq

src/GHCMod.hs

@@ -6,41 +6,40 @@ import Config (cProjectVersion)
 import MonadUtils (liftIO)
 import Control.Applicative
 import Control.Monad
-import Control.Exception ( SomeException(..), fromException, Exception
-                         , Handler(..), catches, throw)
 import Data.Typeable (Typeable)
 import Data.Version (showVersion)
-import Data.Default
 import Data.List
 import Data.List.Split
-import Data.Maybe
 import Data.Char (isSpace)
+import Data.Maybe
+import Exception
 import Language.Haskell.GhcMod
-import Language.Haskell.GhcMod.Internal
+import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
 import Paths_ghc_mod
 import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))
 import qualified System.Console.GetOpt as O
-import System.Directory (setCurrentDirectory)
+import System.FilePath ((</>))
-import System.Environment (getArgs,getProgName)
+import System.Directory (setCurrentDirectory, getAppUserDataDirectory,
+                        removeDirectoryRecursive)
+import System.Environment (getArgs)
 import System.Exit (exitFailure)
-import System.IO (hPutStrLn, stdout, stderr, hSetEncoding, utf8, hFlush)
+import System.IO (stdout, hSetEncoding, utf8, hFlush)
-import System.IO.Unsafe (unsafePerformIO)
+import System.Exit (exitSuccess)
-import System.FilePath (takeFileName)
-import System.Exit (ExitCode, exitSuccess)
 import Text.PrettyPrint
+import Prelude
 
 import Misc
 
-
+progVersion :: String -> String
-
+progVersion pf =
-progVersion :: String
+    "ghc-mod"++pf++" version " ++ showVersion version ++ " compiled by GHC "
-progVersion =
-    progName ++ " version " ++ showVersion version ++ " compiled by GHC "
                                ++ cProjectVersion ++ "\n"
 
--- TODO: remove (ghc) version prefix!
+ghcModVersion :: String
-progName :: String
+ghcModVersion = progVersion ""
-progName = unsafePerformIO $ takeFileName <$> getProgName
+
+ghcModiVersion :: String
+ghcModiVersion = progVersion "i"
 
 optionUsage :: (String -> String) -> [OptDescr a] -> [String]
 optionUsage indent opts = concatMap optUsage opts
@@ -65,33 +64,27 @@ optionUsage indent opts = concatMap optUsage opts
             ReqArg _ label -> s ++ label
             OptArg _ label -> s ++ "["++label++"]"
 
+-- TODO: Generate the stuff below automatically
 usage :: String
 usage =
-    case progName of
+ "Usage: ghc-mod [OPTIONS...] COMMAND [CMD_ARGS...] \n\
-      "ghc-modi" -> ghcModiUsage
-      _ -> ghcModUsage
-
--- TODO: Generate the stuff below automatically
-ghcModUsage :: String
-ghcModUsage =
- "Usage: ghc-mod [OPTIONS...] COMMAND [OPTIONS...] \n\
  \*Global Options (OPTIONS)*\n\
  \    Global options can be specified before and after the command and\n\
  \    interspersed with command specific options\n\
  \\n"
    ++ (unlines $ indent <$> optionUsage indent globalArgSpec) ++
  "*Commands*\n\
- \    - version | --version\n\
+ \    - version\n\
  \        Print the version of the program.\n\
  \\n\
- \    - help | --help\n\
+ \    - help\n\
  \       Print this help message.\n\
  \\n\
  \    - list [FLAGS...] | modules [FLAGS...]\n\
  \        List all visible modules.\n\
  \      Flags:\n\
  \        -d\n\
- \            Also print the modules' package.\n\
+ \            Print package modules belong to.\n\
  \\n\
  \    - lang\n\
  \        List all known GHC language extensions.\n\
@@ -183,12 +176,12 @@ ghcModUsage =
  \        -l\n\
  \            Option to be passed to hlint.\n\
  \\n\
- \    - root FILE\n\
+ \    - root\n\
- \       Try to find the project directory given FILE. For Cabal\n\
+ \        Try to find the project directory. For Cabal projects this is the\n\
- \       projects this is the directory containing the cabal file, for\n\
+ \        directory containing the cabal file, for projects that use a cabal\n\
- \       projects that use a cabal sandbox but have no cabal file this is the\n\
+ \        sandbox but have no cabal file this is the directory containing the\n\
- \       directory containing the sandbox and otherwise this is the directory\n\
+ \        cabal.sandbox.config file and otherwise this is the current\n\
- \       containing FILE.\n\
+ \        directory.\n\
  \\n\
  \    - doc MODULE\n\
  \        Try finding the html documentation directory for the given MODULE.\n\
@@ -197,57 +190,46 @@ ghcModUsage =
  \        Print debugging information. Please include the output in any bug\n\
  \        reports you submit.\n\
  \\n\
- \    - boot\n\
+ \    - debugComponent [MODULE_OR_FILE...]\n\
- \         Internal command used by the emacs frontend.\n"
+ \        Debugging information related to cabal component resolution.\n\
- -- "\n\
- -- \The following forms are supported so ghc-mod can be invoked by\n\
- -- \`cabal repl':\n\
- -- \\n\
- -- \     ghc-mod --make GHC_OPTIONS\n\
- -- \         Pass all options through to the GHC executable.\n\
- -- \\n\
- -- \     ghc-mod --interactive GHC_OPTIONS [--ghc-mod]\n\
- -- \         Start ghci emulation mode. GHC_OPTIONS are passed to the\n\
- -- \         GHC API. If `--ghc-mod' is given ghc-mod specific extensions\n\
- -- \         are enabled.\n"
- where
-   indent = ("    "++)
-
-ghcModiUsage :: String
-ghcModiUsage =
- "Usage: ghc-modi [OPTIONS...] COMMAND\n\
- \*Options*\n"
-   ++ (unlines $ indent <$> optionUsage indent globalArgSpec) ++
- "*Commands*\n\
- \    - version | --version\n\
- \        Print the version of the program.\n\
  \\n\
- \    - help | --help\n\
+ \    - boot\n\
- \       Print this help message.\n"
+ \         Internal command used by the emacs frontend.\n\
+ \\n\
+ \    - legacy-interactive\n\
+ \         ghc-modi compatibility mode.\n"
  where
    indent = ("    "++)
 
-
-
-
 cmdUsage :: String -> String -> String
-cmdUsage cmd s =
+cmdUsage cmd realUsage =
   let
       -- Find command head
-      a = dropWhile (not . (("    - " ++ cmd) `isInfixOf`)) $ lines s
+      a = dropWhile (not . isCmdHead) $ lines realUsage
       -- Take til the end of the current command block
       b = flip takeWhile a $ \l ->
-           all isSpace l || (isIndented l && (isCurrCmdHead l || isNotCmdHead l))
+            all isSpace l || (isIndented l && (isCmdHead l || isNotCmdHead l))
       -- Drop extra newline from the end
       c = dropWhileEnd (all isSpace) b
 
       isIndented    = ("    " `isPrefixOf`)
       isNotCmdHead  = ( not .  ("    - " `isPrefixOf`))
-      isCurrCmdHead = (("    - " ++ cmd) `isPrefixOf`)
+
+      containsAnyCmdHead s = (("    - ") `isInfixOf` s)
+      containsCurrCmdHead s = (("    - " ++ cmd) `isInfixOf` s)
+      isCmdHead s =
+          containsAnyCmdHead s &&
+            or [ containsCurrCmdHead s
+               , any (cmd `isPrefixOf`) (splitOn " | " s)
+               ]
 
       unindent (' ':' ':' ':' ':l) = l
       unindent l = l
   in unlines $ unindent <$> c
+
+ghcModStyle :: Style
+ghcModStyle = style { lineLength = 80, ribbonsPerLine = 1.2 }
+
 ----------------------------------------------------------------
 
 option :: [Char] -> [String] -> String -> ArgDescr a -> OptDescr a
@@ -256,43 +238,78 @@ option s l udsc dsc = Option s l dsc udsc
 reqArg :: String -> (String -> a) -> ArgDescr a
 reqArg udsc dsc = ReqArg dsc udsc
 
-globalArgSpec :: [OptDescr (Options -> Options)]
+optArg :: String -> (Maybe String -> a) -> ArgDescr a
+optArg udsc dsc = OptArg dsc udsc
+
+intToLogLevel :: Int -> GmLogLevel
+intToLogLevel = toEnum
+
+globalArgSpec :: [OptDescr (Options -> Either [String] Options)]
 globalArgSpec =
-      [ option "v" ["verbose"] "Be more verbose." $
+      [ option "v" ["verbose"] "Increase or set log level. (0-7)" $
-               NoArg $ \o -> o { ghcUserOptions = "-v" : ghcUserOptions o }
+               optArg "LEVEL" $ \ml o -> Right $ o {
+                   logLevel = case ml of
+                                Nothing -> increaseLogLevel (logLevel o)
+                                Just l -> toEnum $ min 7 $ read l
+                 }
+
+      , option "s" [] "Be silent, set log level to 0" $
+               NoArg $ \o -> Right $ o { logLevel = toEnum 0 }
 
       , option "l" ["tolisp"] "Format output as an S-Expression" $
-               NoArg $ \o -> o { outputStyle = LispStyle }
+               NoArg $ \o -> Right $ o { outputStyle = LispStyle }
 
-      , option "b" ["boundary"] "Output line separator"$
+      , option "b" ["boundary", "line-seperator"] "Output line separator"$
-               reqArg "SEP" $ \s o -> o { lineSeparator = LineSeparator s }
+               reqArg "SEP" $ \s o -> Right $ o { lineSeparator = LineSeparator s }
+      , option "" ["line-prefix"] "Output line separator"$
+               reqArg "OUT,ERR" $ \s o -> let
+                     [out, err] = splitOn "," s
+                   in Right $ o { linePrefix = Just (out, err) }
 
-      , option "g" ["ghcOpt"] "Option to be passed to GHC" $
+      , option "g" ["ghcOpt", "ghc-option"] "Option to be passed to GHC" $
-               reqArg "OPT" $ \g o ->
+               reqArg "OPT" $ \g o -> Right $
                    o { ghcUserOptions = g : ghcUserOptions o }
 
       , option "" ["with-ghc"] "GHC executable to use" $
-               reqArg "PROG" $ \p o -> o { ghcProgram = p }
+               reqArg "PROG" $ \p o -> Right $ o { ghcProgram = p }
+
+      , option "" ["with-ghc-pkg"] "ghc-pkg executable to use (only needed when guessing from GHC path fails)" $
+               reqArg "PROG" $ \p o -> Right $ o { ghcPkgProgram = p }
 
       , option "" ["with-cabal"] "cabal-install executable to use" $
-               reqArg "PROG" $ \p o -> o { cabalProgram = p }
+               reqArg "PROG" $ \p o -> Right $ o { cabalProgram = p }
+
+      , option "" ["version"] "print version information" $
+               NoArg $ \_ -> Left ["version"]
+
+      , option "" ["help"] "print this help message" $
+               NoArg $ \_ -> Left ["help"]
+
   ]
 
 
 parseGlobalArgs :: [String] -> Either InvalidCommandLine (Options, [String])
 parseGlobalArgs argv
-    = case O.getOpt RequireOrder globalArgSpec argv of
+    = case O.getOpt' RequireOrder globalArgSpec argv of
-        (o,r,[]  ) -> Right $ (foldr id defaultOptions o, r)
+        (o,r,u,[]) -> case foldr (=<<) (Right defaultOptions) o of
-        (_,_,errs) -> Left $ InvalidCommandLine $ Right $
+                        Right o' -> Right (o', u ++ r)
-            "Parsing command line options failed: " ++ concat errs
+                        Left c -> Right (defaultOptions, c)
+        (_,_,u,e)  -> Left $ InvalidCommandLine $ Right $
+            "Parsing command line options failed: "
+               ++ concat (e ++ map errUnrec u)
+ where
+   errUnrec :: String -> String
+   errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n"
 
-parseCommandArgs :: [OptDescr (Options -> Options)]
+parseCommandArgs :: [OptDescr (Options -> Either [String] Options)]
                  -> [String]
                  -> Options
                  -> (Options, [String])
 parseCommandArgs spec argv opts
     = case O.getOpt RequireOrder (globalArgSpec ++ spec) argv of
-        (o,r,[])   -> (foldr id opts o, r)
+        (o,r,[])   -> case foldr (=<<) (Right opts) o of
+                        Right o' -> (o', r)
+                        Left c -> (defaultOptions, c)
         (_,_,errs) ->
             fatalError $ "Parsing command options failed: " ++ concat errs
 
@@ -306,121 +323,65 @@ data CmdError = UnknownCommand String
 
 instance Exception CmdError
 
-----------------------------------------------------------------
-
 data InteractiveOptions = InteractiveOptions {
       ghcModExtensions :: Bool
     }
 
-instance Default InteractiveOptions where
+handler :: IOish m => GhcModT m a -> GhcModT m a
-    def = InteractiveOptions False
+handler = flip gcatches $
-
+          [ GHandler $ \(FatalError msg) -> exitError msg
-handler :: IO a -> IO a
+          , GHandler $ \(InvalidCommandLine e) -> do
-handler = flip catches $
-          [ Handler $ \(FatalError msg) -> exitError msg
-          , Handler $ \(InvalidCommandLine e) -> do
                 case e of
                   Left cmd ->
-                      exitError $ (cmdUsage cmd ghcModUsage) ++ "\n"
+                      exitError $ "Usage for `"++cmd++"' command:\n\n"
-                                  ++ progName ++ ": Invalid command line form."
+                                  ++ (cmdUsage cmd usage) ++ "\n"
-                  Right msg -> exitError $ progName ++ ": " ++ msg
+                                  ++ "ghc-mod: Invalid command line form."
+                  Right msg -> exitError $ "ghc-mod: " ++ msg
+          , GHandler $ \(SomeException e) -> exitError $ "ghc-mod: " ++ show e
           ]
 
 main :: IO ()
-main = handler $ do
+main = do
     hSetEncoding stdout utf8
     args <- getArgs
-
-    -- This doesn't handle --help and --version being given after any global
-    -- options. To do that we'd have to fiddle with getOpt.
     case parseGlobalArgs args of
-      Left e -> case globalCommands args of
+      Left e -> throw e
-                  Just s -> putStr s
+      Right res -> progMain res
-                  Nothing -> throw e
-
-      Right res@(_,cmdArgs) ->
-          case globalCommands cmdArgs of
-            Just s -> putStr s
-            Nothing -> progMain res
 
 progMain :: (Options,[String]) -> IO ()
-progMain (globalOptions,cmdArgs) = do
+progMain (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ handler $ do
-    -- let (ghcArgs, modArgs) = second stripSeperator $ span (/="--") args
+    case globalCommands cmdArgs of
-    --     _realGhcArgs = filter (/="--ghc-mod") ghcArgs
+      Just s -> gmPutStr s
-
+      Nothing -> ghcCommands cmdArgs
-    --     (globalOptions,_cmdArgs) = parseGlobalArgs modArgs
+ where
-
+   hndle action = do
-    --     stripSeperator ("--":rest) = rest
+     (e, _l) <- action
-    --     stripSeperator l = l
+     case e of
-
+       Right _ ->
-    case progName of
+           return ()
-      "ghc-modi" -> do
+       Left ed ->
-          legacyInteractive globalOptions =<< emptyNewUnGetLine
+           exitError' globalOptions $ renderStyle ghcModStyle (gmeDoc ed)
-
-
-      _
-          -- | "--numeric-version" `elem` ghcArgs || "--make" `elem` ghcArgs -> do
-          --     rawSystem (ghcProgram globalOptions) realGhcArgs >>= exitWith
-
-          -- | "--interactive" `elem` ghcArgs -> do
-          --     let interactiveOptions = if "--ghc-mod" `elem` ghcArgs
-          --                              then def { ghcModExtensions = True }
-          --                              else def
-
-          --     -- TODO: pass ghcArgs' to ghc API
-          --     putStrLn "\ninteractive\n"
-          --     --print realGhcArgs
-          --     (res, _) <- runGhcModT globalOptions $ undefined
-          --     case res of
-          --       Right s -> putStr s
-          --       Left e -> exitError $ render (gmeDoc e)
-
-
-          | otherwise -> do
-                  (res,_) <- runGhcModT globalOptions $ ghcCommands cmdArgs
-                  case res of
-                    Right s -> putStr s
-                    Left e -> exitError $ render (gmeDoc e)
-
-              -- Obtain ghc options by letting ourselfs be executed by
-              -- @cabal repl@
-              -- TODO: need to do something about non-cabal projects
-              -- exe <- ghcModExecutable
-              -- let cabalArgs = ["repl", "-v0", "--with-ghc="++exe]
-              --              ++ (("--ghc-option="++) `map` ("--ghc-mod":"--":args))
-
-              -- print cabalArgs
-
-              -- rawSystem "cabal" cabalArgs >>= exitWith
-
 
+globalCommands :: [String] -> Maybe String
+globalCommands (cmd:_)
+    | cmd == "help"    = Just usage
+    | cmd == "version" = Just ghcModVersion
+globalCommands _       = Nothing
 
 -- ghc-modi
-legacyInteractive :: Options -> UnGetLine -> IO ()
+legacyInteractive :: IOish m => GhcModT m ()
-legacyInteractive opt ref = flip catches handlers $ do
+legacyInteractive = do
-    (res,_) <- runGhcModT opt $ do
+    opt <- options
-             symdbreq <- liftIO $ newSymDbReq opt
+    prepareCabalHelper
-             world <- liftIO . getCurrentWorld =<< cradle
+    tmpdir <- cradleTempDir <$> cradle
-             legacyInteractiveLoop symdbreq ref world
+    symdbreq <- liftIO $ newSymDbReq opt tmpdir
+    world <- getCurrentWorld
+    legacyInteractiveLoop symdbreq world
 
-    case res of
+bug :: IOish m => String -> GhcModT m ()
-      Right () -> return ()
-      Left e -> putStrLn $ notGood $ render (gmeDoc e)
-
- where
-   handlers = [ Handler $ \Restart -> legacyInteractive opt ref ]
-
-isExitCodeException :: SomeException -> Bool
-isExitCodeException e = isJust mExitCode
- where
-   mExitCode :: Maybe ExitCode
-   mExitCode = fromException e
-
-
-bug :: String -> IO ()
 bug msg = do
-  putStrLn $ notGood $ "BUG: " ++ msg
+  gmPutStrLn $ notGood $ "BUG: " ++ msg
-  exitFailure
+  liftIO exitFailure
 
 notGood :: String -> String
 notGood msg = "NG " ++ escapeNewlines msg
@@ -431,30 +392,26 @@ escapeNewlines = replace "\n" "\\n" . replace "\\n" "\\\\n"
 replace :: String -> String -> String -> String
 replace needle replacement = intercalate replacement . splitOn needle
 
-
 legacyInteractiveLoop :: IOish m
-                      => SymDbReq -> UnGetLine -> World -> GhcModT m ()
+                      => SymDbReq -> World -> GhcModT m ()
-legacyInteractiveLoop symdbreq ref world = do
+legacyInteractiveLoop symdbreq world = do
     liftIO . setCurrentDirectory =<< cradleRootDir <$> cradle
 
     -- blocking
-    cmdArg <- liftIO $ getCommand ref
+    cmdArg <- liftIO $ getLine
 
     -- after blocking, we need to see if the world has changed.
 
-    changed <- liftIO . didWorldChange world =<< cradle
+    changed <- didWorldChange world
     when changed $ do
-        liftIO $ ungetCommand ref cmdArg
+        dropSession
-        throw Restart
-
-    liftIO . prepareAutogen =<< cradle
 
     let (cmd':args') = split (keepDelimsR $ condense $ whenElt isSpace) cmdArg
         arg = concat args'
         cmd = dropWhileEnd isSpace cmd'
         args = dropWhileEnd isSpace `map` args'
 
-    res <- case dropWhileEnd isSpace cmd of
+    res <- flip gcatches interactiveHandlers $ case dropWhileEnd isSpace cmd of
         "check"  -> checkSyntaxCmd [arg]
         "lint"   -> lintCmd [arg]
         "find"    -> do
@@ -476,22 +433,20 @@ legacyInteractiveLoop symdbreq ref world = do
         ""       -> liftIO $ exitSuccess
         _        -> fatalError $ "unknown command: `" ++ cmd ++ "'"
 
-    liftIO $ putStr res >> putStrLn "OK" >> hFlush stdout
+    gmPutStr res >> gmPutStrLn "OK" >> liftIO (hFlush stdout)
-    legacyInteractiveLoop symdbreq ref world
+    legacyInteractiveLoop symdbreq world
-
-
-globalCommands :: [String] -> Maybe String
-globalCommands []      = Nothing
-globalCommands (cmd:_) = case cmd of
-    _ | cmd == "help"    || cmd == "--help"    -> Just usage
-    _ | cmd == "version" || cmd == "--version" -> Just progVersion
-    _                                          -> Nothing
-
-ghcCommands :: IOish m => [String] -> GhcModT m String
-ghcCommands []         = fatalError "No command given (try --help)"
-ghcCommands (cmd:args) = fn args
  where
-   fn = case cmd of
+   interactiveHandlers =
+          [ GHandler $ \e@(FatalError _) -> throw e
+          , GHandler $ \(SomeException e) -> gmErrStrLn (show e) >> return ""
+          ]
+
+ghcCommands :: IOish m => [String] -> GhcModT m ()
+ghcCommands []         = fatalError "No command given (try --help)"
+ghcCommands (cmd:args) = do
+    gmPutStr =<< action args
+ where
+   action = case cmd of
      _ | cmd == "list" || cmd == "modules" -> modulesCmd
      "lang"    -> languagesCmd
      "flag"    -> flagsCmd
@@ -499,6 +454,7 @@ ghcCommands (cmd:args) = fn args
      "check"   -> checkSyntaxCmd
      "expand"  -> expandTemplateCmd
      "debug"   -> debugInfoCmd
+     "debug-component" -> componentInfoCmd
      "info"    -> infoCmd
      "type"    -> typesCmd
      "split"   -> splitsCmd
@@ -511,6 +467,8 @@ ghcCommands (cmd:args) = fn args
      "doc"     -> pkgDocCmd
      "dumpsym" -> dumpSymbolCmd
      "boot"    -> bootCmd
+     "legacy-interactive" -> legacyInteractiveCmd
+--     "nuke-caches" -> nukeCachesCmd
      _         -> fatalError $ "unknown command: `" ++ cmd ++ "'"
 
 newtype FatalError = FatalError String deriving (Show, Typeable)
@@ -520,14 +478,18 @@ newtype InvalidCommandLine = InvalidCommandLine (Either String String)
     deriving (Show, Typeable)
 instance Exception InvalidCommandLine
 
-exitError :: String -> IO a
+exitError :: IOish m => String -> GhcModT m a
-exitError msg = hPutStrLn stderr msg >> exitFailure
+exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure
+
+exitError' :: Options -> String -> IO a
+exitError' opts msg =
+    gmUnsafeErrStrLn opts (dropWhileEnd (=='\n') msg) >> liftIO exitFailure
 
 fatalError :: String -> a
-fatalError s = throw $ FatalError $ progName ++ ": " ++ s
+fatalError s = throw $ FatalError $ "ghc-mod: " ++ s
 
 withParseCmd :: IOish m
-             => [OptDescr (Options -> Options)]
+             => [OptDescr (Options -> Either [String] Options)]
              -> ([String] -> GhcModT m a)
              -> [String]
              -> GhcModT m a
@@ -535,23 +497,41 @@ withParseCmd spec action args  = do
   (opts', rest) <- parseCommandArgs spec args <$> options
   withOptions (const opts') $ action rest
 
+withParseCmd' :: (IOish m, ExceptionMonad m)
+              => String
+              -> [OptDescr (Options -> Either [String] Options)]
+              -> ([String] -> GhcModT m a)
+              -> [String]
+              -> GhcModT m a
+withParseCmd' cmd spec action args =
+    catchArgs cmd $ withParseCmd spec action args
+
+catchArgs :: (Monad m, ExceptionMonad m) => String -> m a -> m a
+catchArgs cmd action =
+    action `gcatch` \(PatternMatchFail _) ->
+        throw $ InvalidCommandLine (Left cmd)
+
 modulesCmd, languagesCmd, flagsCmd, browseCmd, checkSyntaxCmd, expandTemplateCmd,
-  debugInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd, refineCmd, autoCmd,
+  debugInfoCmd, componentInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd,
-  findSymbolCmd, lintCmd, rootInfoCmd, pkgDocCmd, dumpSymbolCmd, bootCmd
+  refineCmd, autoCmd, findSymbolCmd, lintCmd, rootInfoCmd, pkgDocCmd,
+  dumpSymbolCmd, bootCmd, legacyInteractiveCmd, nukeCachesCmd
   :: IOish m => [String] -> GhcModT m String
 
-modulesCmd    = withParseCmd [] $ \[] -> modules
+modulesCmd    = withParseCmd' "modules" s $ \[] -> modules
-languagesCmd  = withParseCmd [] $ \[] -> languages
+ where s = modulesArgSpec
-flagsCmd      = withParseCmd [] $ \[] -> flags
+languagesCmd  = withParseCmd' "lang"    [] $ \[] -> languages
-debugInfoCmd  = withParseCmd [] $ \[] -> debugInfo
+flagsCmd      = withParseCmd' "flag"    [] $ \[] -> flags
-rootInfoCmd   = withParseCmd [] $ \[] -> rootInfo
+debugInfoCmd  = withParseCmd' "debug"   [] $ \[] -> debugInfo
+rootInfoCmd   = withParseCmd' "root"    [] $ \[] -> rootInfo
+componentInfoCmd = withParseCmd' "debugComponent" [] $ \ts -> componentInfo ts
 -- internal
-bootCmd       = withParseCmd [] $ \[] -> boot
+bootCmd       = withParseCmd' "boot" [] $ \[] -> boot
+nukeCachesCmd = withParseCmd' "nuke-caches" [] $ \[] -> nukeCaches >> return ""
 
-dumpSymbolCmd     = withParseCmd [] $ \[tmpdir] -> dumpSymbol tmpdir
+dumpSymbolCmd     = withParseCmd' "dump" [] $ \[tmpdir] -> dumpSymbol tmpdir
-findSymbolCmd     = withParseCmd [] $ \[sym]  -> findSymbol sym
+findSymbolCmd     = withParseCmd' "find" [] $ \[sym]  -> findSymbol sym
-pkgDocCmd         = withParseCmd [] $ \[mdl]  -> pkgDoc mdl
+pkgDocCmd         = withParseCmd' "doc"  [] $ \[mdl]  -> pkgDoc mdl
-lintCmd           = withParseCmd s  $ \[file] -> lint file
+lintCmd           = withParseCmd' "lint" s  $ \[file] -> lint file
  where s = hlintArgSpec
 browseCmd         = withParseCmd s $ \mdls -> concat <$> browse `mapM` mdls
  where s = browseArgSpec
@@ -565,10 +545,20 @@ autoCmd       = withParseCmd [] $ locAction  "auto"   auto
 refineCmd     = withParseCmd [] $ locAction' "refine" refine
 
 infoCmd       = withParseCmd [] $ action
-  where action [file,_,expr] = info file expr
+  where action [file,_,expr] = info file $ Expression expr
-        action [file,expr]   = info file expr
+        action [file,expr]   = info file $ Expression expr
         action _ = throw $ InvalidCommandLine (Left "info")
 
+legacyInteractiveCmd = withParseCmd [] go
+ where
+   go [] =
+       legacyInteractive >> return ""
+   go ("help":[]) =
+       return usage
+   go ("version":[]) =
+       return ghcModiVersion
+   go _ = throw $ InvalidCommandLine (Left "legacy-interactive")
+
 checkAction :: ([t] -> a) -> [t] -> a
 checkAction _ []         = throw $ InvalidCommandLine (Right "No files given.")
 checkAction action files = action files
@@ -578,22 +568,43 @@ locAction _ action [file,_,line,col] = action file (read line) (read col)
 locAction _ action [file,  line,col] = action file (read line) (read col)
 locAction cmd _ _ = throw $ InvalidCommandLine (Left cmd)
 
-locAction' :: String -> (String -> Int -> Int -> String -> a) -> [String] -> a
+locAction' :: String -> (String -> Int -> Int -> Expression -> a) -> [String] -> a
-locAction' _ action [f,_,line,col,expr] = action f (read line) (read col) expr
+locAction' _ action [f,_,line,col,expr] = action f (read line) (read col) (Expression expr)
-locAction' _ action [f,  line,col,expr] = action f (read line) (read col) expr
+locAction' _ action [f,  line,col,expr] = action f (read line) (read col) (Expression expr)
 locAction' cmd _ _ = throw $ InvalidCommandLine (Left cmd)
 
-hlintArgSpec :: [OptDescr (Options -> Options)]
+
+modulesArgSpec :: [OptDescr (Options -> Either [String] Options)]
+modulesArgSpec =
+    [ option "d" ["detailed"] "Print package modules belong to." $
+             NoArg $ \o -> Right $ o { detailed = True }
+    ]
+
+
+hlintArgSpec :: [OptDescr (Options -> Either [String] Options)]
 hlintArgSpec =
     [ option "h" ["hlintOpt"] "Option to be passed to hlint" $
-             reqArg "hlintOpt" $ \h o -> o { hlintOpts = h : hlintOpts o }
+             reqArg "hlintOpt" $ \h o -> Right $ o { hlintOpts = h : hlintOpts o }
     ]
-browseArgSpec :: [OptDescr (Options -> Options)]
+
+browseArgSpec :: [OptDescr (Options -> Either [String] Options)]
 browseArgSpec =
     [ option "o" ["operators"] "Also print operators." $
-             NoArg $ \o -> o { operators = True }
+             NoArg $ \o -> Right $ o { operators = True }
     , option "d" ["detailed"] "Print symbols with accompanying signature." $
-             NoArg $ \o -> o { detailed = True }
+             NoArg $ \o -> Right $ o { detailed = True }
     , option "q" ["qualified"] "Qualify symbols" $
-             NoArg $ \o -> o { qualified = True }
+             NoArg $ \o -> Right $ o { qualified = True }
     ]
+
+nukeCaches :: IOish m => GhcModT m ()
+nukeCaches = do
+  chdir <- liftIO $ (</> "cabal-helper") <$> getAppUserDataDirectory "ghc-mod"
+  c <- cradle
+
+  when (cradleProjectType c == CabalProject) $ do
+    let root = cradleRootDir c
+    liftIO $ (trySome . removeDirectoryRecursive) `mapM_` [chdir, root </> "dist"]
+
+trySome :: IO a -> IO (Either SomeException a)
+trySome = try

src/GHCModi.hs

@@ -1,262 +1,55 @@
 {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
 
 -- | WARNING
--- This program in the process of being deprecated, use `ghc-mod --interactive`
+-- This program is deprecated, use `ghc-mod legacy-interactive` instead.
--- instead.
-
--- Commands:
---  check <file>
---  find <symbol>
---  info <file> <expr>
---  type <file> <line> <column>
---  lint [hlint options] <file>
---     the format of hlint options is [String] because they may contain
---     spaces and also <file> may contain spaces.
---  boot
---  browse [<package>:]<module>
---  quit
---
--- Session separators:
---   OK -- success
---   NG -- failure
 
 module Main where
 
-import Config (cProjectVersion)
+import Control.Applicative
-import Control.Applicative ((<$>))
+import Control.Monad
-import Control.Exception (SomeException(..))
+import Control.Exception
-import qualified Control.Exception as E
+import Data.Version
-import Control.Monad (when)
+import Data.Maybe
-import CoreMonad (liftIO)
+import System.IO
-import Data.List (intercalate)
+import System.Exit
-import Data.List.Split (splitOn)
+import System.Process
-import Data.Version (showVersion)
+import System.FilePath
-import Language.Haskell.GhcMod
+import System.Environment
-import Language.Haskell.GhcMod.Internal
 import Paths_ghc_mod
-import System.Console.GetOpt
-import System.Directory (setCurrentDirectory)
-import System.Environment (getArgs)
-import System.Exit (ExitCode, exitFailure)
-import System.IO (hFlush,stdout)
-
-import Misc
 import Utils
-
+import Prelude
-----------------------------------------------------------------
-
-progVersion :: String
-progVersion = "ghc-modi version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n"
-
-argspec :: [OptDescr (Options -> Options)]
-argspec = [ Option "b" ["boundary"]
-            (ReqArg (\s opts -> opts { lineSeparator = LineSeparator s }) "sep")
-            "specify line separator (default is Nul string)"
-          , Option "l" ["tolisp"]
-            (NoArg (\opts -> opts { outputStyle = LispStyle }))
-            "print as a list of Lisp"
-          , Option "g" []
-            (ReqArg (\s opts -> opts { ghcUserOptions = s : ghcUserOptions opts }) "flag") "specify a ghc flag"
-          ]
-
-usage :: String
-usage =    progVersion
-        ++ "Usage:\n"
-        ++ "\t ghc-modi [-l] [-b sep] [-g flag]\n"
-        ++ "\t ghc-modi version\n"
-        ++ "\t ghc-modi help\n"
-
-parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String])
-parseArgs spec argv
-    = case getOpt Permute spec argv of
-        (o,n,[]  ) -> (foldr id defaultOptions o, n)
-        (_,_,errs) -> E.throw (CmdArg errs)
-
-----------------------------------------------------------------
-
--- Running two GHC monad threads disables the handling of
--- C-c since installSignalHandlers is called twice, sigh.
 
 main :: IO ()
-main = E.handle cmdHandler $
+main = do
-    go =<< parseArgs argspec <$> getArgs
+  hPutStrLn stderr $
-  where
+    "Warning: ghc-modi is deprecated please use 'ghc-mod legacy-interactive' instead"
-    cmdHandler (CmdArg _) = putStr $ usageInfo usage argspec
-    go (_,"help":_) = putStr $ usageInfo usage argspec
-    go (_,"version":_) = putStr progVersion
-    go (opt,_) = emptyNewUnGetLine >>= run opt
 
-run :: Options -> UnGetLine -> IO ()
+  args <- getArgs
-run opt ref = flip E.catches handlers $ do
+  bindir <- getBinDir
-    cradle0 <- findCradle
+  let installedExe = bindir </> "ghc-mod"
-    let rootdir = cradleRootDir cradle0
+  mexe <- mplus <$> mightExist installedExe <*> pathExe
---        c = cradle0 { cradleCurrentDir = rootdir } TODO: ?????
+  case mexe of
-    setCurrentDirectory rootdir
+    Nothing -> do
-    prepareAutogen cradle0
+      hPutStrLn stderr $
-    -- Asynchronous db loading starts here.
+        "ghc-modi: Could not find '"++installedExe++"', check your installation!"
-    symdbreq <- newSymDbReq opt
+      exitWith $ ExitFailure 1
-    (res, _) <- runGhcModT opt $ do
-        crdl <- cradle
-        world <- liftIO $ getCurrentWorld crdl
-        loop symdbreq ref world
-    case res of
-        Right () -> return ()
-        Left (GMECabalConfigure msg) -> do
-            putStrLn $ notGood $ "cabal configure failed: " ++ show msg
-            exitFailure
-        Left e -> bug $ show e
-  where
-    -- this is just in case.
-    -- If an error is caught here, it is a bug of GhcMod library.
-    handlers = [ E.Handler (\(_ :: ExitCode) -> return ())
-               , E.Handler (\(_ :: Restart) -> run opt ref)
-               , E.Handler (\(SomeException e) -> bug $ show e) ]
 
-bug :: String -> IO ()
+    Just exe -> do
-bug msg = do
+      (_, _, _, h) <-
-  putStrLn $ notGood $ "BUG: " ++ msg
+          createProcess $ proc exe $ ["legacy-interactive"] ++ args
-  exitFailure
+      exitWith =<< waitForProcess h
 
-notGood :: String -> String
+pathExe :: IO (Maybe String)
-notGood msg = "NG " ++ escapeNewlines msg
+pathExe = do
+  ev <- try $ words <$> readProcess "ghc-mod" ["--version"] ""
+  let mexe = case ev of
+               Left (SomeException _) -> Nothing
+               Right ["ghc-mod", "version", ver
+                     , "compiled", "by", "GHC", _]
+                   | showVersion version == ver -> do
+                       Just "ghc-mod"
+               Right _ -> Nothing
 
-escapeNewlines :: String -> String
+  when (isNothing mexe) $
-escapeNewlines = replace "\n" "\\n" . replace "\\n" "\\\\n"
+      hPutStrLn stderr "ghc-modi: ghc-mod executable on PATH has different version, check your installation!"
-
+  return mexe
-replace :: String -> String -> String -> String
-replace needle replacement = intercalate replacement . splitOn needle
-
-----------------------------------------------------------------
-
-loop :: IOish m => SymDbReq -> UnGetLine -> World -> GhcModT m ()
-loop symdbreq ref world = do
-    -- blocking
-    cmdArg <- liftIO $ getCommand ref
-    -- after blocking, we need to see if the world has changed.
-    crdl <- cradle
-    changed <- liftIO $ didWorldChange world crdl
-    when changed $ do
-        liftIO $ ungetCommand ref cmdArg
-        E.throw Restart
-    cradle >>= liftIO . prepareAutogen
-    let (cmd,arg') = break (== ' ') cmdArg
-        arg = dropWhile (== ' ') arg'
-    (ret,ok) <- case cmd of
-        "check"  -> checkStx arg
-        "find"   -> findSym arg symdbreq
-        "lint"   -> lintStx arg
-        "info"   -> showInfo arg
-        "type"   -> showType arg
-        "split"  -> doSplit arg
-        "sig"    -> doSig arg
-        "refine" -> doRefine arg
-        "auto"   -> doAuto arg
-        "boot"   -> bootIt
-        "browse" -> browseIt arg
-        "quit"   -> return ("quit", False)
-        ""       -> return ("quit", False)
-        _        -> return ([], True)
-    if ok then do
-        liftIO $ putStr ret
-        liftIO $ putStrLn "OK"
-      else do
-        liftIO $ putStrLn $ notGood ret
-    liftIO $ hFlush stdout
-    when ok $ loop symdbreq ref world
-
-----------------------------------------------------------------
-
-checkStx :: IOish m => FilePath -> GhcModT m (String, Bool)
-checkStx file = do
-    eret <- check [file]
-    case eret of
-        Right ret -> return (ret, True)
-        Left ret  -> return (ret, True)
-
-----------------------------------------------------------------
-
-findSym :: IOish m => Symbol -> SymDbReq -> GhcModT m (String, Bool)
-findSym sym symdbreq = do
-    db <- getDb symdbreq >>= checkDb symdbreq
-    ret <- lookupSymbol sym db
-    return (ret, True)
-
-lintStx :: IOish m => FilePath -> GhcModT m (String, Bool)
-lintStx optFile = do
-    ret <- withOptions changeOpt $ lint file
-    return (ret, True)
-  where
-    (opts,file) = parseLintOptions optFile
-    hopts = if opts == "" then [] else read opts
-    changeOpt o = o { hlintOpts = hopts }
-
--- |
--- >>> parseLintOptions "[\"--ignore=Use camelCase\", \"--ignore=Eta reduce\"] file name"
--- (["--ignore=Use camelCase", "--ignore=Eta reduce"], "file name")
--- >>> parseLintOptions "file name"
--- ([], "file name")
-parseLintOptions :: String -> (String, String)
-parseLintOptions optFile = case brk (== ']') (dropWhile (/= '[') optFile) of
-    ("","")      -> ([],   optFile)
-    (opt',file') -> (opt', dropWhile (== ' ') file')
-  where
-    brk _ []         =  ([],[])
-    brk p (x:xs')
-        | p x        =  ([x],xs')
-        | otherwise  =  let (ys,zs) = brk p xs' in (x:ys,zs)
-
-----------------------------------------------------------------
-
-showInfo :: IOish m => FilePath -> GhcModT m (String, Bool)
-showInfo fileArg = do
-    let [file, expr] = splitN 2 fileArg
-    ret <- info file expr
-    return (ret, True)
-
-showType :: IOish m => FilePath -> GhcModT m (String, Bool)
-showType fileArg  = do
-    let [file, line, column] = splitN 3 fileArg
-    ret <- types file (read line) (read column)
-    return (ret, True)
-
-doSplit :: IOish m => FilePath -> GhcModT m (String, Bool)
-doSplit fileArg  = do
-    let [file, line, column] = splitN 3 fileArg
-    ret <- splits file (read line) (read column)
-    return (ret, True)
-
-doSig :: IOish m => FilePath -> GhcModT m (String, Bool)
-doSig fileArg  = do
-    let [file, line, column] = splitN 3 fileArg
-    ret <- sig file (read line) (read column)
-    return (ret, True)
-
-doRefine :: IOish m => FilePath -> GhcModT m (String, Bool)
-doRefine fileArg  = do
-    let [file, line, column, expr] = splitN 4 fileArg
-    ret <- refine file (read line) (read column) expr
-    return (ret, True)
-
-doAuto :: IOish m => FilePath -> GhcModT m (String, Bool)
-doAuto fileArg  = do
-    let [file, line, column] = splitN 3 fileArg
-    ret <- auto file (read line) (read column)
-    return (ret, True)
-
-----------------------------------------------------------------
-
-bootIt :: IOish m => GhcModT m (String, Bool)
-bootIt = do
-    ret <- boot
-    return (ret, True)
-
-browseIt :: IOish m => ModuleString -> GhcModT m (String, Bool)
-browseIt mdl = do
-    let (det,rest') = break (== ' ') mdl
-        rest = dropWhile (== ' ') rest'
-    ret <- if det == "-d"
-               then withOptions setDetailed (browse rest)
-               else browse mdl
-    return (ret, True)
-  where
-    setDetailed opt = opt { detailed = True }

src/Misc.hs

@@ -1,75 +1,28 @@
 {-# LANGUAGE DeriveDataTypeable, CPP #-}
 
 module Misc (
-    GHCModiError(..)
+    SymDbReq
-  , Restart(..)
-  , UnGetLine
-  , emptyNewUnGetLine
-  , ungetCommand
-  , getCommand
-  , SymDbReq
   , newSymDbReq
   , getDb
   , checkDb
-  , prepareAutogen
   ) where
 
-import Control.Applicative ((<$>))
-import Control.Concurrent (threadDelay)
 import Control.Concurrent.Async (Async, async, wait)
-import Control.Exception (Exception)
-import Control.Monad (unless, when)
 import CoreMonad (liftIO)
 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
-import Data.List (isPrefixOf)
+import Prelude
-import Data.Maybe (isJust)
-import Data.Typeable (Typeable)
-import System.Directory (doesDirectoryExist, getDirectoryContents)
-import System.IO (openBinaryFile, IOMode(..))
-import System.Process
 
 import Language.Haskell.GhcMod
-import Language.Haskell.GhcMod.Internal
+import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
-
-----------------------------------------------------------------
-
-data GHCModiError = CmdArg [String] deriving (Show, Typeable)
-
-instance Exception GHCModiError
-
-----------------------------------------------------------------
-
-data Restart = Restart deriving (Show, Typeable)
-
-instance Exception Restart
-
-----------------------------------------------------------------
-
-newtype UnGetLine = UnGetLine (IORef (Maybe String))
-
-emptyNewUnGetLine :: IO UnGetLine
-emptyNewUnGetLine = UnGetLine <$> newIORef Nothing
-
-ungetCommand :: UnGetLine -> String -> IO ()
-ungetCommand (UnGetLine ref) cmd = writeIORef ref (Just cmd)
-
-getCommand :: UnGetLine -> IO String
-getCommand (UnGetLine ref) = do
-    mcmd <- readIORef ref
-    case mcmd of
-        Nothing -> getLine
-        Just cmd -> do
-            writeIORef ref Nothing
-            return cmd
 
 ----------------------------------------------------------------
 
 type SymDbReqAction = (Either GhcModError SymbolDb, GhcModLog)
 data SymDbReq = SymDbReq (IORef (Async SymDbReqAction)) (IO SymDbReqAction)
 
-newSymDbReq :: Options -> IO SymDbReq
+newSymDbReq :: Options -> FilePath -> IO SymDbReq
-newSymDbReq opt = do
+newSymDbReq opt dir = do
-    let act = runGhcModT opt loadSymbolDb
+    let act = runGhcModT opt $ loadSymbolDb dir
     req <- async act
     ref <- newIORef req
     return $ SymDbReq ref act
@@ -83,7 +36,7 @@ getDb (SymDbReq ref _) = do
 
 checkDb :: IOish m => SymDbReq -> SymbolDb -> GhcModT m SymbolDb
 checkDb (SymDbReq ref act) db = do
-    outdated <- liftIO $ isOutdated db
+    outdated <- isOutdated db
     if outdated then do
         -- async and wait here is unnecessary because this is essentially
         -- synchronous. But Async can be used a cache.
@@ -92,63 +45,3 @@ checkDb (SymDbReq ref act) db = do
         hoistGhcModT =<< liftIO (wait req)
       else
         return db
-
-----------------------------------------------------------------
-
-build :: IO ProcessHandle
-build = do
-#ifdef WINDOWS
-    nul <- openBinaryFile "NUL" AppendMode
-#else
-    nul <- openBinaryFile "/dev/null" AppendMode
-#endif
-    (_, _, _, hdl) <- createProcess $ pro nul
-    return hdl
- where
-   pro nul = CreateProcess {
-       cmdspec = RawCommand "cabal" ["build"]
-     , cwd = Nothing
-     , env = Nothing
-     , std_in = Inherit
-     , std_out = UseHandle nul
-     , std_err = UseHandle nul
-     , close_fds = False
-#if __GLASGOW_HASKELL__ >= 702
-      , create_group = True
-#endif
-#if __GLASGOW_HASKELL__ >= 707
-      , delegate_ctlc = False
-#endif
-     }
-
-autogen :: String
-autogen = "dist/build/autogen"
-
-isAutogenPrepared :: IO Bool
-isAutogenPrepared = do
-    exist <- doesDirectoryExist autogen
-    if exist then do
-        files <- filter ("." `isPrefixOf`) <$> getDirectoryContents autogen
-        if length files >= 2 then
-            return True
-          else
-            return False
-      else
-        return False
-
-watch :: Int -> ProcessHandle -> IO ()
-watch 0 _ = return ()
-watch n hdl = do
-    prepared <- isAutogenPrepared
-    if prepared then
-        interruptProcessGroupOf hdl
-      else do
-        threadDelay 100000
-        watch (n - 1) hdl
-
-prepareAutogen :: Cradle -> IO ()
-prepareAutogen crdl = when (isJust $ cradleCabalFile crdl) $ do
-    prepared <- isAutogenPrepared
-    unless prepared $ do
-        hdl <- build
-        watch 30 hdl

src/Utils.hs

@@ -1,27 +0,0 @@
-module Utils where
-
--- |
---
--- >>> split "foo bar baz"
--- ["foo","bar baz"]
--- >>> split "foo  bar  baz"
--- ["foo","bar  baz"]
-split :: String -> [String]
-split xs = [ys, dropWhile isSpace zs]
-  where
-    isSpace = (== ' ')
-    (ys,zs) = break isSpace xs
-
--- |
---
--- >>> splitN 0 "foo  bar  baz"
--- ["foo","bar  baz"]
--- >>> splitN 2 "foo  bar  baz"
--- ["foo","bar  baz"]
--- >>> splitN 3 "foo  bar  baz"
--- ["foo","bar","baz"]
-splitN :: Int -> String -> [String]
-splitN n xs
-  | n <= 2    = split xs
-  | otherwise = let [ys,zs] = split xs
-                in ys : splitN (n - 1) zs

test/BrowseSpec.hs

@@ -26,7 +26,8 @@ spec = do
             syms `shouldContain` ["Left :: a -> Either a b"]
 
     describe "`browse' in a project directory" $ do
-        it "lists symbols defined in a a local module (e.g. `Baz.baz)" $ do
+        it "can list symbols defined in a a local module" $ do
-            withDirectory_ "test/data" $ do
+            withDirectory_ "test/data/ghc-mod-check/lib" $ do
-                syms <- runID $ lines <$> browse "Baz"
+                syms <- runD $ lines <$> browse "Data.Foo"
-                syms `shouldContain` ["baz"]
+                syms `shouldContain` ["foo"]
+                syms `shouldContain` ["fibonacci"]

test/CabalApiSpec.hs

@@ -1,77 +0,0 @@
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module CabalApiSpec where
-
-import Control.Applicative
-import Language.Haskell.GhcMod.CabalApi
-import Language.Haskell.GhcMod.Cradle
-import Language.Haskell.GhcMod.Types
-import Test.Hspec
-import System.Directory
-import System.FilePath
-import System.Process (readProcess)
-
-import Dir
-import TestUtils
-
-import Config (cProjectVersionInt) -- ghc version
-
-ghcVersion :: Int
-ghcVersion = read cProjectVersionInt
-
-spec :: Spec
-spec = do
-    describe "parseCabalFile" $ do
-        it "throws an exception if the cabal file is broken" $ do
-            shouldReturnError $ do
-              withDirectory_ "test/data/broken-cabal" $ do
-                  crdl <- findCradle
-                  runD' $ parseCabalFile crdl "broken.cabal"
-
-
-    describe "getCompilerOptions" $ do
-        it "gets necessary CompilerOptions" $ do
-            cwd <- getCurrentDirectory
-            withDirectory "test/data/subdir1/subdir2" $ \dir -> do
-                crdl <- findCradle
-                let Just cabalFile = cradleCabalFile crdl
-                pkgDesc <- runD $ parseCabalFile crdl cabalFile
-                res <- runD $ getCompilerOptions [] crdl pkgDesc
-                let res' = res {
-                        ghcOptions  = ghcOptions res
-                      , includeDirs = map (toRelativeDir dir) (includeDirs res)
-                      }
-                if ghcVersion < 706
-                  then ghcOptions res' `shouldContain` ["-global-package-conf", "-no-user-package-conf","-package-conf",cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"]
-                  else ghcOptions res' `shouldContain` ["-global-package-db", "-no-user-package-db","-package-db",cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d","-XHaskell98"]
-                includeDirs res' `shouldBe` ["test/data","test/data/dist/build","test/data/dist/build/autogen","test/data/subdir1/subdir2","test/data/test"]
-                (pkgName `map` depPackages res') `shouldContain` ["Cabal"]
-
-
-    describe "cabalDependPackages" $ do
-        it "extracts dependent packages" $ do
-            crdl <- findCradle' "test/data/"
-            pkgs <- cabalDependPackages . cabalAllBuildInfo <$> runD (parseCabalFile crdl "test/data/cabalapi.cabal")
-            pkgs `shouldBe` ["Cabal","base","template-haskell"]
-        it "uses non default flags" $ do
-            withDirectory_ "test/data/cabal-flags" $ do
-                crdl <- findCradle
-                _ <- readProcess "cabal" ["configure", "-ftest-flag"] ""
-                pkgs <- cabalDependPackages . cabalAllBuildInfo <$> runD (parseCabalFile crdl "cabal-flags.cabal")
-                pkgs `shouldBe` ["Cabal","base"]
-
-    describe "cabalSourceDirs" $ do
-        it "extracts all hs-source-dirs" $ do
-            crdl <- findCradle' "test/data/check-test-subdir"
-            dirs <- cabalSourceDirs . cabalAllBuildInfo <$> runD (parseCabalFile crdl "test/data/check-test-subdir/check-test-subdir.cabal")
-            dirs `shouldBe` ["src", "test"]
-        it "extracts all hs-source-dirs including \".\"" $ do
-            crdl <- findCradle' "test/data/"
-            dirs <- cabalSourceDirs . cabalAllBuildInfo <$> runD (parseCabalFile crdl "test/data/cabalapi.cabal")
-            dirs `shouldBe` [".", "test"]
-
-    describe "cabalAllBuildInfo" $ do
-        it "extracts build info" $ do
-            crdl <- findCradle' "test/data/"
-            info <- cabalAllBuildInfo <$> runD (parseCabalFile crdl "test/data/cabalapi.cabal")
-            show info `shouldBe` "[BuildInfo {buildable = True, buildTools = [], cppOptions = [], ccOptions = [], ldOptions = [], pkgconfigDepends = [], frameworks = [], cSources = [], hsSourceDirs = [\".\"], otherModules = [ModuleName [\"Browse\"],ModuleName [\"CabalApi\"],ModuleName [\"Cabal\"],ModuleName [\"CabalDev\"],ModuleName [\"Check\"],ModuleName [\"ErrMsg\"],ModuleName [\"Flag\"],ModuleName [\"GHCApi\"],ModuleName [\"GHCChoice\"],ModuleName [\"Gap\"],ModuleName [\"Info\"],ModuleName [\"Lang\"],ModuleName [\"Lint\"],ModuleName [\"List\"],ModuleName [\"Paths_ghc_mod\"],ModuleName [\"Types\"]], defaultLanguage = Nothing, otherLanguages = [], defaultExtensions = [], otherExtensions = [], oldExtensions = [], extraLibs = [], extraLibDirs = [], includeDirs = [], includes = [], installIncludes = [], options = [(GHC,[\"-Wall\"])], ghcProfOptions = [], ghcSharedOptions = [], customFieldsBI = [], targetBuildDepends = [Dependency (PackageName \"Cabal\") (UnionVersionRanges (ThisVersion (Version {versionBranch = [1,10], versionTags = []})) (LaterVersion (Version {versionBranch = [1,10], versionTags = []}))),Dependency (PackageName \"base\") (IntersectVersionRanges (UnionVersionRanges (ThisVersion (Version {versionBranch = [4,0], versionTags = []})) (LaterVersion (Version {versionBranch = [4,0], versionTags = []}))) (EarlierVersion (Version {versionBranch = [5], versionTags = []}))),Dependency (PackageName \"template-haskell\") AnyVersion]},BuildInfo {buildable = True, buildTools = [], cppOptions = [], ccOptions = [], ldOptions = [], pkgconfigDepends = [], frameworks = [], cSources = [], hsSourceDirs = [\"test\",\".\"], otherModules = [ModuleName [\"Expectation\"],ModuleName [\"BrowseSpec\"],ModuleName [\"CabalApiSpec\"],ModuleName [\"FlagSpec\"],ModuleName [\"LangSpec\"],ModuleName [\"LintSpec\"],ModuleName [\"ListSpec\"]], defaultLanguage = Nothing, otherLanguages = [], defaultExtensions = [], otherExtensions = [], oldExtensions = [], extraLibs = [], extraLibDirs = [], includeDirs = [], includes = [], installIncludes = [], options = [], ghcProfOptions = [], ghcSharedOptions = [], customFieldsBI = [], targetBuildDepends = [Dependency (PackageName \"Cabal\") (UnionVersionRanges (ThisVersion (Version {versionBranch = [1,10], versionTags = []})) (LaterVersion (Version {versionBranch = [1,10], versionTags = []}))),Dependency (PackageName \"base\") (IntersectVersionRanges (UnionVersionRanges (ThisVersion (Version {versionBranch = [4,0], versionTags = []})) (LaterVersion (Version {versionBranch = [4,0], versionTags = []}))) (EarlierVersion (Version {versionBranch = [5], versionTags = []})))]}]"

test/CabalHelperSpec.hs

@@ -0,0 +1,96 @@
+module CabalHelperSpec where
+
+import Control.Arrow
+import Control.Applicative
+import Distribution.Helper
+import Language.Haskell.GhcMod.CabalHelper
+import Language.Haskell.GhcMod.PathsAndFiles
+import Language.Haskell.GhcMod.Error
+import Test.Hspec
+import System.Directory
+import System.FilePath
+import System.Process (readProcess, system)
+
+import Dir
+import TestUtils
+import Data.List
+
+import Config (cProjectVersionInt)
+
+ghcVersion :: Int
+ghcVersion = read cProjectVersionInt
+
+gmeProcessException :: GhcModError -> Bool
+gmeProcessException GMEProcess {} = True
+gmeProcessException _ = False
+
+pkgOptions :: [String] -> [String]
+pkgOptions [] = []
+pkgOptions (_:[]) = []
+pkgOptions (x:y:xs) | x == "-package-id" = [name y] ++ pkgOptions xs
+                    | otherwise = pkgOptions (y:xs)
+ where
+   stripDash s = maybe s id $ (flip drop s . (+1) <$> findIndex (=='-') s)
+   name s = reverse $ stripDash $ stripDash $ reverse s
+
+idirOpts :: [(c, [String])] -> [(c, [String])]
+idirOpts = map (second $ map (drop 2) . filter ("-i"`isPrefixOf`))
+
+spec :: Spec
+spec = do
+    describe "getComponents" $ do
+        it "throws an exception if the cabal file is broken" $ do
+            let tdir = "test/data/broken-cabal"
+            runD' tdir getComponents `shouldThrow` anyIOException
+
+        it "handles sandboxes correctly" $ do
+            let tdir = "test/data/cabal-project"
+            cwd <- getCurrentDirectory
+
+            -- TODO: ChSetupHsName should also have sandbox stuff, see related
+            -- comment in cabal-helper
+            opts <- map gmcGhcOpts . filter ((/= ChSetupHsName) . gmcName) <$> runD' tdir getComponents
+
+            bp <- buildPlatform readProcess
+            if ghcVersion < 706
+              then forM_ opts (\o -> o `shouldContain` ["-no-user-package-conf","-package-conf", cwd </> "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir bp])
+              else forM_ opts (\o -> o `shouldContain` ["-no-user-package-db","-package-db",cwd </> "test/data/cabal-project/.cabal-sandbox/"++ghcSandboxPkgDbDir bp])
+
+        it "extracts build dependencies" $ do
+            let tdir = "test/data/cabal-project"
+            opts <- map gmcGhcOpts <$> runD' tdir getComponents
+            let ghcOpts = head opts
+                pkgs = pkgOptions ghcOpts
+            pkgs `shouldBe` ["Cabal","base","template-haskell"]
+
+        it "uses non default flags" $ do
+            let tdir = "test/data/cabal-flags"
+            _ <- withDirectory_ tdir $
+                readProcess "cabal" ["configure", "-ftest-flag"] ""
+
+            opts <- map gmcGhcOpts <$> runD' tdir getComponents
+            let ghcOpts = head opts
+                pkgs = pkgOptions ghcOpts
+            pkgs `shouldBe` ["Cabal","base"]
+
+    describe "getCustomPkgDbStack" $ do
+        it "works" $ do
+            let tdir = "test/data/custom-cradle"
+            Just stack <- runD' tdir $ getCustomPkgDbStack
+            stack `shouldBe` [ GlobalDb
+                             , UserDb
+                             , PackageDb "package-db-a"
+                             , PackageDb "package-db-b"
+                             , PackageDb "package-db-c"
+                             ]
+
+    describe "getPackageDbStack'" $ do
+        it "fixes out of sync custom pkg-db stack" $ do
+            withDirectory_ "test/data/custom-cradle" $ do
+                _ <- system "cabal configure"
+                (s, s') <- runD $ do
+                    Just stack <- getCustomPkgDbStack
+                    withCabal $ do
+                        stack' <- getCabalPackageDbStack
+                        return (stack, stack')
+                s' `shouldBe` s

test/CheckSpec.hs

@@ -1,9 +1,10 @@
 {-# LANGUAGE CPP #-}
 module CheckSpec where
 
-import Data.List (isSuffixOf, isInfixOf, isPrefixOf)
 import Language.Haskell.GhcMod
-import System.FilePath
+
+import Data.List
+import System.Process
 import Test.Hspec
 
 import TestUtils
@@ -14,38 +15,55 @@ spec = do
     describe "checkSyntax" $ do
         it "works even if an executable depends on the library defined in the same cabal file" $ do
             withDirectory_ "test/data/ghc-mod-check" $ do
-                res <- runID $ checkSyntax ["main.hs"]
+                res <- runD $ checkSyntax ["main.hs"]
                 res `shouldBe` "main.hs:5:1:Warning: Top-level binding with no type signature: main :: IO ()\n"
 
+
         it "works even if a module imports another module from a different directory" $ do
             withDirectory_ "test/data/check-test-subdir" $ do
-                res <- runID $ checkSyntax ["test/Bar/Baz.hs"]
+                _ <- system "cabal configure --enable-tests"
+                res <- runD $ checkSyntax ["test/Bar/Baz.hs"]
                 res `shouldSatisfy` (("test" </> "Foo.hs:3:1:Warning: Top-level binding with no type signature: foo :: [Char]\n") `isSuffixOf`)
 
         it "detects cyclic imports" $ do
-            withDirectory_ "test/data" $ do
+            withDirectory_ "test/data/import-cycle" $ do
-                res <- runID $ checkSyntax ["Mutual1.hs"]
+                res <- runD $ checkSyntax ["Mutual1.hs"]
                 res `shouldSatisfy` ("Module imports form a cycle" `isInfixOf`)
 
         it "works with modules using QuasiQuotes" $ do
-            withDirectory_ "test/data" $ do
+            withDirectory_ "test/data/quasi-quotes" $ do
-                res <- runID $ checkSyntax ["Baz.hs"]
+                res <- runD $ checkSyntax ["QuasiQuotes.hs"]
-                res `shouldSatisfy` ("Baz.hs:5:1:Warning:" `isPrefixOf`)
+                res `shouldSatisfy` ("QuasiQuotes.hs:6:1:Warning:" `isInfixOf`)
 
 #if __GLASGOW_HASKELL__ >= 708
         it "works with modules using PatternSynonyms" $ do
             withDirectory_ "test/data/pattern-synonyms" $ do
-                res <- runID $ checkSyntax ["B.hs"]
+                res <- runD $ checkSyntax ["B.hs"]
                 res `shouldSatisfy` ("B.hs:6:9:Warning:" `isPrefixOf`)
 #endif
 
         it "works with foreign exports" $ do
-            withDirectory_ "test/data" $ do
+            withDirectory_ "test/data/foreign-export" $ do
-                res <- runID $ checkSyntax ["ForeignExport.hs"]
+                res <- runD $ checkSyntax ["ForeignExport.hs"]
                 res `shouldBe` ""
 
         context "when no errors are found" $ do
             it "doesn't output an empty line" $ do
-                withDirectory_ "test/data/ghc-mod-check/Data" $ do
+                withDirectory_ "test/data/ghc-mod-check/lib/Data" $ do
-                    res <- runID $ checkSyntax ["Foo.hs"]
+                    res <- runD $ checkSyntax ["Foo.hs"]
                     res `shouldBe` ""
+
+#if __GLASGOW_HASKELL__ >= 708
+-- See https://github.com/kazu-yamamoto/ghc-mod/issues/507
+        it "emits warnings generated in GHC's desugar stage" $ do
+            withDirectory_ "test/data/check-missing-warnings" $ do
+                res <- runD $ checkSyntax ["DesugarWarnings.hs"]
+                res `shouldBe` "DesugarWarnings.hs:4:9:Warning: Pattern match(es) are non-exhaustive\NULIn a case alternative: Patterns not matched: _ : _\n"
+#endif
+
+        it "works with cabal builtin preprocessors" $ do
+            withDirectory_ "test/data/cabal-preprocessors" $ do
+                _ <- system "cabal clean"
+                _ <- system "cabal build"
+                res <- runD $ checkSyntax ["Main.hs"]
+                res `shouldBe` "Preprocessed.hsc:3:1:Warning: Top-level binding with no type signature: warning :: ()\n"

test/CradleSpec.hs

@@ -4,46 +4,23 @@ import Control.Applicative
 import Data.List (isSuffixOf)
 import Language.Haskell.GhcMod.Cradle
 import Language.Haskell.GhcMod.Types
-import System.Directory (canonicalizePath,getCurrentDirectory)
+import System.Directory (canonicalizePath)
-import System.FilePath ((</>), pathSeparator)
+import System.FilePath (pathSeparator)
 import Test.Hspec
 
 import Dir
 
-spec :: Spec
+clean_ :: IO Cradle -> IO Cradle
-spec = do
+clean_ f = do
-    describe "findCradle" $ do
+  crdl <- f
-        it "returns the current directory" $ do
+  cleanupCradle crdl
-            withDirectory_ "/" $ do
+  return crdl
-                curDir <- stripLastDot <$> canonicalizePath "/"
-                res <- findCradle
-                cradleCurrentDir res `shouldBe` curDir
-                cradleRootDir    res `shouldBe` curDir
-                cradleCabalFile  res `shouldBe` Nothing
-                cradlePkgDbStack res `shouldBe` [GlobalDb,UserDb]
-
-        it "finds a cabal file and a sandbox" $ do
-            cwd <- getCurrentDirectory
-            withDirectory "test/data/subdir1/subdir2" $ \dir -> do
-                res <- relativeCradle dir <$> findCradle
-                cradleCurrentDir res `shouldBe` "test" </> "data" </> "subdir1" </> "subdir2"
-                cradleRootDir    res `shouldBe` "test" </> "data"
-                cradleCabalFile  res `shouldBe` Just ("test" </> "data" </> "cabalapi.cabal")
-                cradlePkgDbStack res `shouldBe` [GlobalDb, PackageDb (cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d")]
-
-        it "works even if a sandbox config file is broken" $ do
-            withDirectory "test/data/broken-sandbox" $ \dir -> do
-                res <- relativeCradle dir <$> findCradle
-                cradleCurrentDir res `shouldBe` "test" </> "data" </> "broken-sandbox"
-                cradleRootDir    res `shouldBe` "test" </> "data" </> "broken-sandbox"
-                cradleCabalFile  res `shouldBe` Just ("test" </> "data" </> "broken-sandbox" </> "dummy.cabal")
-                cradlePkgDbStack res `shouldBe` [GlobalDb, UserDb]
 
 relativeCradle :: FilePath -> Cradle -> Cradle
-relativeCradle dir cradle = cradle {
+relativeCradle dir crdl = crdl {
-    cradleCurrentDir    = toRelativeDir dir  $  cradleCurrentDir cradle
+    cradleCurrentDir    = toRelativeDir dir  $  cradleCurrentDir crdl
-  , cradleRootDir       = toRelativeDir dir  $  cradleRootDir    cradle
+  , cradleRootDir       = toRelativeDir dir  $  cradleRootDir    crdl
-  , cradleCabalFile     = toRelativeDir dir <$> cradleCabalFile  cradle
+  , cradleCabalFile     = toRelativeDir dir <$> cradleCabalFile  crdl
   }
 
 -- Work around GHC 7.2.2 where `canonicalizePath "/"` returns "/.".
@@ -51,3 +28,38 @@ stripLastDot :: FilePath -> FilePath
 stripLastDot path
   | (pathSeparator:'.':"") `isSuffixOf` path = init path
   | otherwise = path
+
+spec :: Spec
+spec = do
+    describe "findCradle" $ do
+        it "returns the current directory" $ do
+            withDirectory_ "/" $ do
+                curDir <- stripLastDot <$> canonicalizePath "/"
+                res <- clean_ findCradle
+                cradleCurrentDir res `shouldBe` curDir
+                cradleRootDir    res `shouldBe` curDir
+                cradleCabalFile  res `shouldBe` Nothing
+
+        it "finds a cabal file and a sandbox" $ do
+            withDirectory "test/data/cabal-project/subdir1/subdir2" $ \dir -> do
+                res <- relativeCradle dir <$> clean_ findCradle
+
+                cradleCurrentDir res `shouldBe`
+                    "test/data/cabal-project/subdir1/subdir2"
+
+                cradleRootDir    res `shouldBe` "test/data/cabal-project"
+
+                cradleCabalFile  res `shouldBe`
+                    Just ("test/data/cabal-project/cabalapi.cabal")
+
+        it "works even if a sandbox config file is broken" $ do
+            withDirectory "test/data/broken-sandbox" $ \dir -> do
+                res <- relativeCradle dir <$> clean_ findCradle
+                cradleCurrentDir res `shouldBe`
+                    "test" </> "data" </> "broken-sandbox"
+
+                cradleRootDir    res `shouldBe`
+                    "test" </> "data" </> "broken-sandbox"
+
+                cradleCabalFile  res `shouldBe`
+                  Just ("test" </> "data" </> "broken-sandbox" </> "dummy.cabal")

test/Dir.hs

@@ -1,9 +1,15 @@
-module Dir where
+module Dir (
+    module Dir
+  , getCurrentDirectory
+  , (</>)
+  ) where
 
 import Control.Exception as E
 import Data.List (isPrefixOf)
 import System.Directory
-import System.FilePath (addTrailingPathSeparator)
+import System.FilePath (addTrailingPathSeparator,(</>))
+
+
 
 withDirectory_ :: FilePath -> IO a -> IO a
 withDirectory_ dir action = bracket getCurrentDirectory

test/FindSpec.hs

@@ -1,6 +1,7 @@
 module FindSpec where
 
 import Language.Haskell.GhcMod.Find
+import Control.Monad
 import Test.Hspec
 import TestUtils
 
@@ -8,5 +9,5 @@ spec :: Spec
 spec = do
     describe "db <- loadSymbolDb" $ do
         it "lookupSymbol' db \"head\"  contains at least `Data.List'" $ do
-            db <- runD loadSymbolDb
+            db <- runD $ loadSymbolDb =<< (cradleTempDir `liftM` cradle)
-            lookupSym "head" db `shouldContain` ["Data.List"]
+            lookupSym "head" db `shouldContain` [ModuleString "Data.List"]

test/GhcApiSpec.hs

@@ -1,29 +0,0 @@
-module GhcApiSpec where
-
-import Control.Applicative
-import Data.List (sort)
-import Language.Haskell.GhcMod.GHCApi
-import Test.Hspec
-import TestUtils
-
-import Dir
-
-spec :: Spec
-spec = do
-    describe "findModule" $ do
-        it "finds Data.List in `base' and `haskell2010'"
-            $ withDirectory_ "test/data" $ runD $ do
-                pkgs <- findModule "Data.List" <$> ghcPkgDb
-                let pkgNames = pkgName `map` pkgs
-                liftIO $ pkgNames `shouldContain` ["base", "haskell2010"]
-
-    describe "moduleInfo" $ do
-        it "works for modules from global packages (e.g. base:Data.List)"
-            $ withDirectory_ "test/data" $ runD $ do
-                Just info <- moduleInfo (Just ("base","","")) "Data.List"
-                liftIO $ sort (bindings info) `shouldContain` ["++"]
-
-        it "works for local modules"
-            $ withDirectory_ "test/data" $ runD $ do
-                Just info <- moduleInfo Nothing "Baz"
-                liftIO $ bindings info `shouldContain` ["baz"]

test/GhcPkgSpec.hs

@@ -0,0 +1,30 @@
+module GhcPkgSpec where
+
+import Control.Arrow
+import Control.Applicative
+import Distribution.Helper
+import Language.Haskell.GhcMod.GhcPkg
+import Language.Haskell.GhcMod.PathsAndFiles
+import Language.Haskell.GhcMod.CabalHelper
+import Language.Haskell.GhcMod.Error
+import Test.Hspec
+import System.Directory
+import System.FilePath
+import System.Process (readProcess, system)
+
+import Dir
+import TestUtils
+import Data.List
+
+spec :: Spec
+spec = do
+    describe "getPackageDbStack'" $ do
+        it "fixes out of sync custom pkg-db stack" $ do
+            withDirectory_ "test/data/custom-cradle" $ do
+                _ <- system "cabal configure"
+                (s, s') <- runD $ do
+                    Just stack <- getCustomPkgDbStack
+                    withCabal $ do
+                        stack' <- getPackageDbStack
+                        return (stack, stack')
+                s' `shouldBe` s

test/HomeModuleGraphSpec.hs

@@ -0,0 +1,178 @@
+-- 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 OverloadedStrings #-}
+
+module HomeModuleGraphSpec where
+
+import Language.Haskell.GhcMod.HomeModuleGraph
+import Language.Haskell.GhcMod.Target
+import TestUtils
+
+import GHC
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import Data.Maybe
+
+import Test.Hspec
+
+runAGhc :: [GHCOption] -> (HscEnv -> LightGhc a) -> IO a
+runAGhc opts action = withLightHscEnv opts $ \env -> do
+  runLightGhc env $ getSession >>= action
+
+hmGraph :: FilePath -> [String] -> String -> IO GmModuleGraph
+hmGraph dir opts mn = runAGhc opts $ \env -> liftIO $ do
+    runD' dir $ do
+      smp <- liftIO $ findModulePathSet env [mkModuleName mn]
+      homeModuleGraph env smp
+
+uhmGraph :: FilePath -> [String] -> String -> String -> GmModuleGraph -> IO GmModuleGraph
+uhmGraph dir opts mn umn g = runAGhc opts $ \env -> liftIO $ do
+    runD' dir $ do
+      smp <- liftIO $ findModulePathSet env [mkModuleName mn]
+      usmp <- liftIO $ findModulePathSet env [mkModuleName umn]
+      updateHomeModuleGraph env g smp usmp
+
+mapMap :: (Ord k, Ord k')
+  => (k -> k') -> (a -> a') -> Map.Map k a -> Map.Map k' a'
+mapMap fk fa = Map.mapKeys fk . Map.map fa
+
+mapMpFn :: (FilePath -> FilePath) -> ModulePath -> ModulePath
+mapMpFn f (ModulePath mn fn) = ModulePath mn (f fn)
+
+mp :: ModuleName -> ModulePath
+mp mn = ModulePath mn $ moduleNameString mn ++ ".hs"
+
+spec :: Spec
+spec = do
+    describe "reachable" $ do
+        let
+            smp =
+              Set.fromList
+                [ mp "A"
+                , mp "B"
+                , mp "C"
+                , mp "D"
+                , mp "E"
+                , mp "F"
+                , mp "G"
+                , mp "H"
+                , mp "I"
+                ]
+
+            moduleMap = mkModuleMap smp
+
+            completeGraph =
+                Map.map (Set.map lookupMM) . Map.mapKeys lookupMM
+
+            lookupMM = fromJust . flip Map.lookup moduleMap
+
+            graph = completeGraph $
+              Map.fromList
+                [ ("A", Set.fromList ["B"])
+                , ("B", Set.fromList ["C", "D"])
+                , ("C", Set.fromList ["F"])
+                , ("D", Set.fromList ["E"])
+                , ("E", Set.fromList [])
+                , ("F", Set.fromList [])
+                , ("G", Set.fromList [])
+                , ("H", Set.fromList [])
+                , ("I", Set.fromList [])
+                ]
+
+            really_reachable =
+              Set.fromList
+                [ mp "A"
+                , mp "B"
+                , mp "C"
+                , mp "D"
+                , mp "E"
+                , mp "F"
+                ]
+
+            g = GmModuleGraph {
+               gmgGraph     = graph
+             }
+
+        it "reachable Set.empty g == Set.empty" $ do
+            reachable Set.empty g `shouldBe` Set.empty
+
+        it "lists only reachable nodes" $ do
+            reachable (Set.fromList [mp "A"]) g `shouldBe` really_reachable
+
+
+    describe "homeModuleGraph" $ do
+        it "cycles don't break it" $ do
+            let tdir = "test/data/home-module-graph/cycle"
+            g <- hmGraph tdir [] "A"
+            gmgGraph g `shouldBe`
+              Map.fromList
+                [ (mp "A",  Set.fromList [mp "B"])
+                , (mp "B",  Set.fromList [mp "A"])
+                ]
+
+        it "follows imports" $ do
+            let tdir = "test/data/home-module-graph/indirect"
+            g <- hmGraph tdir [] "A"
+            gmgGraph g `shouldBe`
+              Map.fromList
+                [ (mp "A",  Set.fromList [mp "A1", mp "A2", mp "A3"])
+                , (mp "A1", Set.fromList [mp "B"])
+                , (mp "A2", Set.fromList [mp "C"])
+                , (mp "A3", Set.fromList [mp "B"])
+                , (mp "B",  Set.fromList [])
+                , (mp "C",  Set.fromList [])
+                ]
+
+        it "returns partial results on parse errors" $ do
+            let tdir = "test/data/home-module-graph/errors"
+            g <- hmGraph tdir [] "A"
+            gmgGraph g `shouldBe`
+              Map.fromList
+                [ (mp "A",  Set.fromList [mp "A1", mp "A2", mp "A3"])
+                , (mp "A1", Set.fromList [])  -- parse error here
+                , (mp "A2", Set.fromList [])
+                , (mp "A3", Set.fromList [mp "B"])
+                , (mp "B",  Set.fromList [])
+                ]
+
+        it "returns partial results on CPP errors" $ do
+            let tdir = "test/data/home-module-graph/cpp"
+            g <- hmGraph tdir [] "A"
+            gmgGraph g `shouldBe`
+              Map.fromList
+                [ (mp "A",  Set.fromList [mp "A1", mp "A2", mp "A3"])
+                , (mp "A1", Set.fromList [])  -- CPP error here
+                , (mp "A2", Set.fromList [])
+                , (mp "A3", Set.fromList [mp "B"])
+                , (mp "B",  Set.fromList [])
+                ]
+
+    describe "updateHomeModuleGraph" $ do
+        it "removes unreachable nodes" $ do
+            let tdir = "test/data/home-module-graph/indirect"
+            let tdir' = "test/data/home-module-graph/indirect-update"
+            ig <- hmGraph tdir [] "A"
+            g <- uhmGraph tdir' [] "A" "A2" ig
+            gmgGraph g `shouldBe`
+              Map.fromList
+                [ (mp "A",  Set.fromList [mp "A1", mp "A2", mp "A3"])
+                , (mp "A1", Set.fromList [mp "B"])
+                , (mp "A2", Set.fromList [])
+                , (mp "A3", Set.fromList [mp "B"])
+                , (mp "B",  Set.fromList [])
+                -- C was removed
+                ]

test/InfoSpec.hs

@@ -9,51 +9,43 @@ import System.Environment.Executable (getExecutablePath)
 #else
 import System.Environment (getExecutablePath)
 #endif
-import System.Exit
 import System.FilePath
-import System.Process
 import Test.Hspec
 import TestUtils
-import Dir
 
 spec :: Spec
 spec = do
     describe "types" $ do
         it "shows types of the expression and its outers" $ do
-            withDirectory_ "test/data/ghc-mod-check" $ do
+            let tdir = "test/data/ghc-mod-check"
-                res <- runD $ types "Data/Foo.hs" 9 5
+            res <- runD' tdir $ types "lib/Data/Foo.hs" 9 5
             res `shouldBe` "9 5 11 40 \"Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n"
 
         it "works with a module using TemplateHaskell" $ do
-            withDirectory_ "test/data" $ do
+            let tdir = "test/data/template-haskell"
-                res <- runD $ types "Bar.hs" 5 1
+            res <- runD' tdir $ types "Bar.hs" 5 1
             res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]
 
         it "works with a module that imports another module using TemplateHaskell" $ do
-            withDirectory_ "test/data" $ do
+            let tdir = "test/data/template-haskell"
-                res <- runD $ types "Main.hs" 3 8
+            res <- runD' tdir $ types "ImportsTH.hs" 3 8
             res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""]
 
     describe "info" $ do
-        it "works for non-export functions" $ do
+        it "works for non exported functions" $ do
-            withDirectory_ "test/data" $ do
+            let tdir = "test/data/non-exported"
-                res <- runD $ info "Info.hs" "fib"
+            res <- runD' tdir $ info "Fib.hs" $ Expression "fib"
             res `shouldSatisfy` ("fib :: Int -> Int" `isPrefixOf`)
 
         it "works with a module using TemplateHaskell" $ do
-            withDirectory_ "test/data" $ do
+            let tdir = "test/data/template-haskell"
-                res <- runD $ info "Bar.hs" "foo"
+            res <- runD' tdir $ info "Bar.hs" $ Expression "foo"
             res `shouldSatisfy` ("foo :: ExpQ" `isPrefixOf`)
 
         it "works with a module that imports another module using TemplateHaskell" $ do
-            withDirectory_ "test/data" $ do
+            let tdir = "test/data/template-haskell"
-                res <- runD $ info "Main.hs" "bar"
+            res <- runD' tdir $ info "ImportsTH.hs" $ Expression "bar"
             res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`)
 
-        it "doesn't fail on unicode output" $ do
-            dir <- getDistDir
-            code <- rawSystem (dir </> "build/ghc-mod/ghc-mod") ["info", "test/data/Unicode.hs", "Unicode", "unicode"]
-            code `shouldSatisfy` (== ExitSuccess)
-
 getDistDir :: IO FilePath
 getDistDir = takeDirectory . takeDirectory . takeDirectory <$> getExecutablePath

test/LintSpec.hs

@@ -8,10 +8,10 @@ spec :: Spec
 spec = do
     describe "lint" $ do
         it "can detect a redundant import" $ do
-            res <- runD $ lint "test/data/hlint.hs"
+            res <- runD $ lint "test/data/hlint/hlint.hs"
-            res `shouldBe` "test/data/hlint.hs:4:8: Error: Redundant do\NULFound:\NUL  do putStrLn \"Hello, world!\"\NULWhy not:\NUL  putStrLn \"Hello, world!\"\n"
+            res `shouldBe` "test/data/hlint/hlint.hs:4:8: Error: Redundant do\NULFound:\NUL  do putStrLn \"Hello, world!\"\NULWhy not:\NUL  putStrLn \"Hello, world!\"\n"
 
         context "when no suggestions are given" $ do
             it "doesn't output an empty line" $ do
-                res <- runD $ lint "test/data/ghc-mod-check/Data/Foo.hs"
+                res <- runD $ lint "test/data/ghc-mod-check/lib/Data/Foo.hs"
                 res `shouldBe` ""

test/Main.hs

@@ -4,6 +4,7 @@ import Dir
 
 import Control.Exception as E
 import Control.Monad (void)
+import Data.List
 import Language.Haskell.GhcMod (debugInfo)
 import System.Process
 import Test.Hspec
@@ -11,22 +12,38 @@ import TestUtils
 
 main :: IO ()
 main = do
-  let sandboxes = [ "test/data", "test/data/check-packageid"
+  let sandboxes = [ "test/data/cabal-project"
+                  , "test/data/check-packageid"
                   , "test/data/duplicate-pkgver/"
                   , "test/data/broken-cabal/"
                   ]
       genSandboxCfg dir = withDirectory dir $ \cwdir -> do
          system ("sed 's|@CWD@|" ++ cwdir ++ "|g' cabal.sandbox.config.in > cabal.sandbox.config")
       pkgDirs =
-        [ "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"
+        [ "test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"
         , "test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"
         , "test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"]
       genGhcPkgCache dir = system $ "ghc-pkg recache --force -f" ++ dir
+
   genSandboxCfg `mapM_` sandboxes
   genGhcPkgCache `mapM_` pkgDirs
-  void $ system "find test -name setup-config -name ghc-mod.cache -exec rm {} \\;"
+
+  let caches = [ "setup-config"
+               , "setup-config.ghc-mod.cabal-helper"
+               , "setup-config.ghc-mod.cabal-components"
+               , "setup-config.ghc-mod.resolved-components"
+               , "setup-config.ghc-mod.package-options"
+               , "setup-config.ghc-mod.package-db-stack"
+               , "ghc-mod.cache"
+               ]
+      cachesFindExp :: String
+      cachesFindExp = unwords $ intersperse "-o " $ map ("-name "++) caches
+
+      cleanCmd = "find test \\( "++ cachesFindExp ++" \\) -exec rm {} \\;"
+
+  putStrLn $ "$ " ++ cleanCmd
+  void $ system cleanCmd
   void $ system "cabal --version"
-  putStrLn $ "ghc-mod was built with Cabal version " ++ VERSION_Cabal
   void $ system "ghc --version"
 
   (putStrLn =<< runD debugInfo)

test/MonadSpec.hs

@@ -1,39 +1,17 @@
-{-# LANGUAGE ScopedTypeVariables #-}
 module MonadSpec where
 
 import Test.Hspec
-import Dir
 import TestUtils
-import Control.Applicative
-import Control.Exception
 import Control.Monad.Error.Class
 
 spec :: Spec
 spec = do
     describe "When using GhcModT in a do block" $
         it "a pattern match failure causes a call to `fail` on ErrorT in the monad stack" $ do
-             (a, _)
+             (a, _h)
                  <- runGhcModT defaultOptions $
                        do
                          Just _ <- return Nothing
                          return "hello"
                      `catchError` (const $ fail "oh noes")
              a `shouldBe` (Left $ GMEString "oh noes")
-
-    describe "runGhcModT" $
-        it "complains if the cabal file fails to parse while a sandbox is present" $ withDirectory_ "test/data/broken-cabal" $ do
-          shouldReturnError $ runD' (gmCradle <$> ask)
-
-    describe "gmsGet/Put" $
-        it "work" $ do
-          (runD $ gmsPut (GhcModState Intelligent) >> gmsGet)
-            `shouldReturn` (GhcModState Intelligent)
-
-    describe "liftIO" $ do
-        it "converts user errors to GhcModError" $ do
-            shouldReturnError $
-                runD' $ liftIO $ throw (userError "hello") >> return ""
-
-        it "converts a file not found exception to GhcModError" $ do
-            shouldReturnError $
-                runD' $ liftIO $ readFile "/DOES_NOT_EXIST" >> return ""

test/PathsAndFilesSpec.hs

@@ -1,42 +1,33 @@
-{-# LANGUAGE CPP #-}
 module PathsAndFilesSpec where
 
 import Language.Haskell.GhcMod.PathsAndFiles
-#if __GLASGOW_HASKELL__ <= 706
-import Language.Haskell.GhcMod.Types
-import Language.Haskell.GhcMod.GhcPkg
-#endif
 
 import System.Directory
-import System.Environment
+import System.FilePath
-import System.FilePath ((</>))
 import Test.Hspec
+import TestUtils
 
 spec :: Spec
 spec = do
     describe "getSandboxDb" $ do
--- ghc < 7.8
-#if __GLASGOW_HASKELL__ <= 706
-        it "does include a sandbox with ghc < 7.8" $ do
-            cwd <- getCurrentDirectory
-            getPackageDbStack "test/data/" `shouldReturn` [GlobalDb, PackageDb $ cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"]
-#endif
-
         it "can parse a config file and extract the sandbox package-db" $ do
             cwd <- getCurrentDirectory
-            pkgDb <- getSandboxDb "test/data/"
+            Just db <- getSandboxDb "test/data/cabal-project"
-            pkgDb `shouldBe` Just (cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d")
+            db `shouldSatisfy` isPkgDbAt (cwd </> "test/data/cabal-project/.cabal-sandbox")
 
         it "returns Nothing if the sandbox config file is broken" $ do
             getSandboxDb "test/data/broken-sandbox" `shouldReturn` Nothing
 
-    describe "getCabalFiles" $ do
-        it "doesn't think $HOME/.cabal is a cabal file" $ do
-            (getCabalFiles =<< getEnv "HOME") `shouldReturn` []
-
     describe "findCabalFile" $ do
         it "works" $ do
-            findCabalFile "test/data" `shouldReturn` Just "test/data/cabalapi.cabal"
+            findCabalFile "test/data/cabal-project" `shouldReturn` Just "test/data/cabal-project/cabalapi.cabal"
 
         it "finds cabal files in parent directories" $ do
-            findCabalFile "test/data/subdir1/subdir2" `shouldReturn` Just "test/data/cabalapi.cabal"
+            findCabalFile "test/data/cabal-project/subdir1/subdir2" `shouldReturn` Just "test/data/cabal-project/cabalapi.cabal"
+
+    describe "findCabalSandboxDir" $ do
+        it "works" $ do
+            findCabalSandboxDir "test/data/cabal-project" `shouldReturn` Just "test/data/cabal-project"
+
+        it "finds sandboxes in parent directories" $ do
+            findCabalSandboxDir "test/data/cabal-project/subdir1/subdir2" `shouldReturn` Just "test/data/cabal-project"

test/TargetSpec.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE OverloadedStrings #-}
+module TargetSpec where
+
+import Language.Haskell.GhcMod.Target
+import Language.Haskell.GhcMod.Gap
+import Test.Hspec
+
+import TestUtils
+
+import GHC
+import Data.List
+import Data.Maybe
+import System.Directory
+import System.FilePath
+
+spec :: Spec
+spec = do
+    describe "runLightGhc" $ do
+        it "works at all" $ do
+            withLightHscEnv [] $ \env ->
+              runLightGhc env (return ()) `shouldReturn` ()
+
+        it "has modules in scope" $ do
+            withLightHscEnv [] $ \env ->
+              runLightGhc env $ do
+               dflags <- getSessionDynFlags
+               let i = intersect (listVisibleModuleNames dflags)
+                                 ["Control.Applicative", "Control.Arrow"
+                                 ,"Control.Exception", "GHC.Exts", "GHC.Float"]
+               liftIO $ i `shouldSatisfy` not . null
+
+        it "can get module info" $ do
+            withLightHscEnv [] $ \env ->
+              runLightGhc env $ do
+                mdl <- findModule "Data.List" Nothing
+                mmi <- getModuleInfo mdl
+                liftIO $ isJust mmi `shouldBe` True
+
+
+    describe "resolveModule" $ do
+        it "Works when a module given as path uses CPP" $ do
+            dir <- getCurrentDirectory
+            let srcDirs = [dir </> "test/data/target/src"]
+            x <- withLightHscEnv [] $ \env -> runD $ do
+                resolveModule env srcDirs (Left $ dir </> "test/data/target/Cpp.hs")
+            liftIO $ x `shouldBe` Just (ModulePath "Cpp" $ dir </> "test/data/target/Cpp.hs")

test/TestUtils.hs

@@ -1,26 +1,36 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 module TestUtils (
     run
   , runD
   , runD'
-  , runI
+  , runE
-  , runID
+  , runNullLog
-  , runIsolatedGhcMod
-  , isolateCradle
   , shouldReturnError
+  , isPkgDbAt
+  , isPkgConfDAt
   , module Language.Haskell.GhcMod.Monad
   , module Language.Haskell.GhcMod.Types
   ) where
 
+import Language.Haskell.GhcMod.Logging
 import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.Cradle
 import Language.Haskell.GhcMod.Types
 
+import Control.Arrow
+import Control.Applicative
+import Control.Monad.Error (ErrorT, runErrorT)
+import Control.Monad.Trans.Journal
+import Data.List.Split
+import Data.String
+import System.FilePath
+import System.Directory
 import Test.Hspec
 
-isolateCradle :: IOish m => GhcModT m a -> GhcModT m a
+import Exception
-isolateCradle action =
+
-    local modifyEnv  $ action
+testLogLevel :: GmLogLevel
- where
+testLogLevel = GmDebug
-    modifyEnv e = e { gmCradle = (gmCradle e) { cradlePkgDbStack = [GlobalDb] } }
 
 extract :: Show e => IO (Either e a, w) -> IO a
 extract action = do
@@ -29,28 +39,46 @@ extract action = do
     Right a ->  return a
     Left e -> error $ show e
 
-runIsolatedGhcMod :: Options -> GhcModT IO a -> IO a
+withSpecCradle :: IOish m => FilePath -> (Cradle -> m a) -> m a
-runIsolatedGhcMod opt action = do
+withSpecCradle cradledir f =
-  extract $ runGhcModT opt $ isolateCradle action
+    gbracket (liftIO $ findSpecCradle cradledir) (liftIO . cleanupCradle) f
 
--- | Run GhcMod in isolated cradle with default options
+withGhcModEnvSpec :: IOish m => FilePath -> Options -> (GhcModEnv -> m a) -> m a
-runID :: GhcModT IO a -> IO a
+withGhcModEnvSpec dir opt f = withSpecCradle dir $ withGhcModEnv' opt f
-runID = runIsolatedGhcMod defaultOptions
 
--- | Run GhcMod in isolated cradle
+runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog)
-runI :: Options -> GhcModT IO a -> IO a
+runGhcModTSpec opt action = do
-runI = runIsolatedGhcMod
+  dir <- getCurrentDirectory
+  runGhcModTSpec' dir opt action
+
+runGhcModTSpec' :: IOish m
+    => FilePath -> Options -> GhcModT m b -> m (Either GhcModError b, GhcModLog)
+runGhcModTSpec' dir opt action = liftIO (canonicalizePath dir) >>= \dir' ->
+    withGhcModEnvSpec dir' opt $ \env -> do
+      first (fst <$>) <$> runGhcModT'' env defaultGhcModState
+        (gmSetLogLevel (logLevel opt) >> action)
 
 -- | Run GhcMod
 run :: Options -> GhcModT IO a -> IO a
-run opt a = extract $ runGhcModT opt a
+run opt a = extract $ runGhcModTSpec opt a
 
 -- | Run GhcMod with default options
 runD :: GhcModT IO a -> IO a
-runD = extract . runGhcModT defaultOptions
+runD =
+    extract . runGhcModTSpec defaultOptions { logLevel = testLogLevel }
 
-runD' :: GhcModT IO a -> IO (Either GhcModError a, GhcModLog)
+runD' :: FilePath -> GhcModT IO a -> IO a
-runD' = runGhcModT defaultOptions
+runD' dir =
+    extract . runGhcModTSpec' dir defaultOptions { logLevel = testLogLevel }
+
+runE :: ErrorT e IO a -> IO (Either e a)
+runE = runErrorT
+
+runNullLog :: MonadIO m => JournalT GhcModLog m a -> m a
+runNullLog action = do
+  (a,w) <- runJournalT action
+  liftIO $ print w
+  return a
 
 shouldReturnError :: Show a
                   => IO (Either GhcModError a, GhcModLog)
@@ -61,3 +89,21 @@ shouldReturnError action = do
  where
    isLeft (Left _) = True
    isLeft _ = False
+
+isPkgConfD :: FilePath -> Bool
+isPkgConfD d = let
+    (_dir, pkgconfd) = splitFileName d
+    in case splitOn "-" pkgconfd of
+         [_arch, _platform, _compiler, _compver, "packages.conf.d"] -> True
+         _ -> False
+
+isPkgConfDAt :: FilePath -> FilePath -> Bool
+isPkgConfDAt d d' | d == takeDirectory d' && isPkgConfD d' = True
+isPkgConfDAt _ _ = False
+
+isPkgDbAt :: FilePath -> GhcPkgDb -> Bool
+isPkgDbAt d (PackageDb dir) = isPkgConfDAt d dir
+isPkgDbAt _ _ = False
+
+instance IsString ModuleName where
+    fromString = mkModuleName

test/UtilsSpec.hs

@@ -1,23 +0,0 @@
-module UtilsSpec where
-
-import Language.Haskell.GhcMod.Error
-import Language.Haskell.GhcMod.Utils
-import TestUtils
-import Test.Hspec
-
-spec :: Spec
-spec = do
-    describe "extractParens" $ do
-        it "extracts the part of a string surrounded by parentheses" $ do
-            extractParens "asdasdasd ( hello [ world ] )()() kljlkjlkjlk" `shouldBe` "( hello [ world ] )"
-            extractParens "[(PackageName \"template-haskell\",InstalledPackageId \"template-haskell-2.9.0.0-8e2a49468f3b663b671c437d8579cd28\"),(PackageName \"base\",InstalledPackageId \"base-4.7.0.0-e4567cc9a8ef85f78696b03f3547b6d5\"),(PackageName \"Cabal\",InstalledPackageId \"Cabal-1.18.1.3-b9a44a5b15a8bce47d40128ac326e369\")][][]" `shouldBe` "[(PackageName \"template-haskell\",InstalledPackageId \"template-haskell-2.9.0.0-8e2a49468f3b663b671c437d8579cd28\"),(PackageName \"base\",InstalledPackageId \"base-4.7.0.0-e4567cc9a8ef85f78696b03f3547b6d5\"),(PackageName \"Cabal\",InstalledPackageId \"Cabal-1.18.1.3-b9a44a5b15a8bce47d40128ac326e369\")]"
-
-    describe "liftMonadError" $ do
-        it "converts IOErrors to GhcModError" $ do
-            shouldReturnError $
-                runD' $ liftIO $ throw (userError "hello") >> return ""
-
-            shouldReturnError $
-                runD' $ liftIO $ readFile "/DOES_NOT_EXIST" >> return ""
-
--- readProcessWithExitCode cmd opts ""

test/data/Unicode.hs

@@ -1,4 +0,0 @@
-module Unicode where
-
-unicode :: α -> α
-unicode = id

test/data/annotations/With.hs

@@ -0,0 +1,6 @@
+module Main where
+
+{-# ANN module ["this", "can", "be", "anything"] #-}
+
+main :: IO ()
+main = putStrLn "Hello world!"

test/data/bad.config

@@ -1 +0,0 @@
-broken

test/data/cabal-flags/cabal-flags.cabal

@@ -7,8 +7,7 @@ flag test-flag
   default: False
 
 library
-  build-depends: base == 4.*
+  build-depends: base
 
   if flag(test-flag)
     build-depends: Cabal >= 1.10
-

test/data/cabal-preprocessors/Main.hs

@@ -0,0 +1,4 @@
+import Preprocessed
+
+main :: IO ()
+main = return warning

test/data/cabal-preprocessors/Preprocessed.hsc

@@ -0,0 +1,3 @@
+module Preprocessed where
+
+warning = ()

test/data/cabal-preprocessors/cabal-preprocessors.cabal

@@ -0,0 +1,14 @@
+name:                cabal-preprocessors
+version:             0.1.0.0
+license-file:        LICENSE
+author:              asd
+maintainer:          asd
+build-type:          Simple
+cabal-version:       >=1.10
+
+executable cabal-preprocessors
+  main-is:             Main.hs
+  build-depends:       base
+  default-language:    Haskell2010
+  other-modules:       Preprocessed
+  ghc-options:         -Wall