hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' into release

Browse Source
This commit is contained in:
Daniel Gröber 2015-08-14 10:46:26 +02:00
commit eb0413c407
155 changed files with 6601 additions and 3240 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
.gitignore vendored
View File

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

28
.travis.yml
View File

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

661
COPYING.AGPL3 Normal file
View File

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

29
COPYING.BSD3 Normal file
View File

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

33
LICENSE
View File

@ -1,29 +1,6 @@
Copyright (c) 2009, IIJ Innovation Institute Inc.
All rights reserved.
ghc-mod was originally licensed under the BSD3 but the primary license has been
changed to the AGPL3, files originally contributed under the BSD3 license remain
under this license and can generally be identified by the lack of a GPL header.
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.
See the files COPYING.BSD3 and COPYING.AGPL3 in the source distribution for
copies of the two licenses.

23
Language/Haskell/GhcMod.hs
View File

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

6
Language/Haskell/GhcMod/Boot.hs
View File

@ -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,
concat <$> mapM browse preBrowsedModules]
boot = concat <$> sequence ms
where
ms = [modules, languages, flags, concat <$> mapM browse preBrowsedModules]
preBrowsedModules :: [String]
preBrowsedModules = [

88
Language/Haskell/GhcMod/Browse.hs
View File

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

58
Language/Haskell/GhcMod/Cabal18.hs
View File

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

73
Language/Haskell/GhcMod/Cabal21.hs
View File

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

193
Language/Haskell/GhcMod/CabalApi.hs
View File

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

171
Language/Haskell/GhcMod/CabalConfig.hs
View File

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

228
Language/Haskell/GhcMod/CabalHelper.hs Normal file
View File

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

103
Language/Haskell/GhcMod/Caching.hs Normal file
View File

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

52
Language/Haskell/GhcMod/Caching/Types.hs Normal file
View File

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

80
Language/Haskell/GhcMod/CaseSplit.hs
View File

@ -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
where
body = inModuleContext file $ \dflag style -> do
opt <- options
modSum <- Gap.fileModSummary file
whenFound' opt (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of
(SplitInfo varName bndLoc (varLoc,varT) _matches) -> do
let varName' = showName dflag style varName -- Convert name to string
text <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
getTyCons dflag style varName varT)
return (fourInts bndLoc, text)
(TySplitInfo varName bndLoc (varLoc,varT)) -> do
let varName' = showName dflag style varName -- Convert name to string
text <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
getTyCons dflag style varName varT)
return (fourInts bndLoc, text)
handler (SomeException _) = emptyResult =<< options
splits file lineNo colNo =
ghandle handler $ runGmlT' [Left file] deferErrors $ do
opt <- options
crdl <- cradle
style <- getStyle
dflag <- G.getSessionDynFlags
modSum <- Gap.fileModSummary (cradleCurrentDir crdl </> file)
whenFound' opt (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of
(SplitInfo varName bndLoc (varLoc,varT) _matches) -> do
let varName' = showName dflag style varName -- Convert name to string
t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
getTyCons dflag style varName varT)
return (fourInts bndLoc, t)
(TySplitInfo varName bndLoc (varLoc,varT)) -> do
let varName' = showName dflag style varName -- Convert name to string
t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
getTyCons dflag style varName varT)
return (fourInts bndLoc, t)
where
handler (SomeException ex) = do
gmLog GmDebug "splits" $
text "" $$ nest 4 (showDoc ex)
emptyResult =<< options
----------------------------------------------------------------
-- a. Code for getting the information of the variable
@ -79,7 +92,11 @@ 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
return $ getCaseSplitText (T.lines text) info
t <- T.readFile file
return $ getCaseSplitText (T.lines t) info
getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String
getCaseSplitText text (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS
getCaseSplitText t (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS
, sVarSpan = sVS, sTycons = sT }) =
let bindingText = getBindingText text sBS
let bindingText = getBindingText t sBS
difference = srcSpanDifference sBS sVS
replaced = map (replaceVarWithTyCon bindingText difference sVN) sT
-- The newly generated bindings need to be indented to align with the
@ -195,9 +213,9 @@ 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 =

33
Language/Haskell/GhcMod/Check.hs
View File

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

49
Language/Haskell/GhcMod/Convert.hs
View File

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

80
Language/Haskell/GhcMod/Cradle.hs
View File

@ -1,19 +1,22 @@
module Language.Haskell.GhcMod.Cradle (
findCradle
, findCradle'
, findCradleWithoutSandbox
, findSpecCradle
, cleanupCradle
) where
import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils
import Control.Exception.IOChoice ((||>))
import System.Directory (getCurrentDirectory, removeDirectoryRecursive)
import System.FilePath (takeDirectory)
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Maybe
import Data.Maybe
import System.Directory
import System.FilePath
import Prelude
----------------------------------------------------------------
@ -25,51 +28,62 @@ findCradle :: 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
pkgDbStack <- getPackageDbStack sbDir
tmpDir <- newTempDir sbDir
sbDir <- MaybeT $ findCabalSandboxDir wdir
return Cradle {
cradleCurrentDir = wdir
cradleProjectType = SandboxProject
, cradleCurrentDir = wdir
, cradleRootDir = sbDir
, cradleTempDir = tmpDir
, cradleTempDir = error "tmpDir"
, cradleCabalFile = Nothing
, cradlePkgDbStack = pkgDbStack
}
plainCradle :: FilePath -> IO Cradle
plainCradle :: FilePath -> MaybeT IO Cradle
plainCradle wdir = do
tmpDir <- newTempDir wdir
return Cradle {
cradleCurrentDir = wdir
return $ Cradle {
cradleProjectType = PlainProject
, cradleCurrentDir = wdir
, cradleRootDir = wdir
, cradleTempDir = tmpDir
, cradleTempDir = error "tmpDir"
, cradleCabalFile = Nothing
, cradlePkgDbStack = [GlobalDb, UserDb]
}
-- Just for testing
findCradleWithoutSandbox :: IO Cradle
findCradleWithoutSandbox = do
cradle <- findCradle
return cradle { cradlePkgDbStack = [GlobalDb]} -- FIXME

138
Language/Haskell/GhcMod/Debug.hs
View File

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

12
Language/Haskell/GhcMod/Doc.hs
View File

@ -1,9 +1,8 @@
module Language.Haskell.GhcMod.Doc where
import GHC (DynFlags, GhcMonad)
import qualified GHC as G
import GHC
import Language.Haskell.GhcMod.Gap (withStyle, showDocWith)
import Outputable (SDoc, PprStyle, mkUserStyle, Depth(AllTheWay), neverQualify)
import Outputable
import Pretty (Mode(..))
showPage :: DynFlags -> PprStyle -> SDoc -> String
@ -12,9 +11,14 @@ 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

35
Language/Haskell/GhcMod/DynFlags.hs
View File

@ -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)
data Build = CabalPkg | SingleFile deriving Eq
import Prelude
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

198
Language/Haskell/GhcMod/Error.hs
View File

@ -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 Exception
import Data.Version
import System.Process (showCommandForUser)
import Text.PrettyPrint
import Text.Printf
data GhcModError = GMENoMsg
-- ^ Unknown error
| GMEString String
-- ^ Some Error with a message. These are produced mostly by
-- 'fail' calls on GhcModT.
| GMEIOException IOException
-- ^ IOExceptions captured by GhcModT's MonadIO instance
| GMECabalConfigure GhcModError
-- ^ Configuring a cabal project failed.
| GMECabalFlags GhcModError
-- ^ Retrieval of the cabal configuration flags failed.
| GMEProcess [String] GhcModError
-- ^ Launching an operating system process failed. The first
-- field is the command.
| GMENoCabalFile
-- ^ No cabal file found.
| GMETooManyCabalFiles [FilePath]
-- ^ Too many cabal files found.
deriving (Eq,Show,Typeable)
import Exception
import Panic
import Config (cProjectVersion, cHostPlatformString)
import Paths_ghc_mod (version)
instance Exception GhcModError
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Pretty
instance Error GhcModError where
noMsg = GMENoMsg
strMsg = GMEString
type GmError m = MonadError GhcModError m
gmCsfeDoc :: GMConfigStateFileError -> Doc
gmCsfeDoc GMConfigStateFileNoHeader = text $
"Saved package config file header is missing. "
++ "Try re-running the 'configure' command."
gmCsfeDoc GMConfigStateFileBadHeader = text $
"Saved package config file header is corrupt. "
++ "Try re-running the 'configure' command."
gmCsfeDoc GMConfigStateFileNoParse = text $
"Saved package config file body is corrupt. "
++ "Try re-running the 'configure' command."
gmCsfeDoc GMConfigStateFileMissing = text $
"Run the 'configure' command first."
-- gmCsfeDoc (ConfigStateFileBadVersion oldCabal oldCompiler _) = text $
-- "You need to re-run the 'configure' command. "
-- ++ "The version of Cabal being used has changed (was "
-- ++ display oldCabal ++ ", now "
-- ++ display currentCabalId ++ ")."
-- ++ badCompiler
-- where
-- badCompiler
-- | oldCompiler == currentCompilerId = ""
-- | otherwise =
-- " Additionally the compiler is different (was "
-- ++ display oldCompiler ++ ", now "
-- ++ display currentCompilerId
-- ++ ") which is probably the cause of the problem."
gmeDoc :: GhcModError -> Doc
gmeDoc e = case e of
@ -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
GMEProcess cmd msg ->
text ("launching operating system process `"++unwords cmd++"` failed: ")
<> gmeDoc msg
text "Retrieval of the cabal configuration flags failed: " <> gmeDoc msg
GMECabalComponent cn ->
text "Cabal component " <> quotes (gmComponentNameDoc cn)
<> text " could not be found."
GMECabalCompAssignment ctx ->
text "Could not find a consistent component assignment for modules:" $$
(nest 4 $ foldr ($+$) empty $ map ctxDoc ctx) $$
text "" $$
(if all (Set.null . snd) ctx
then noComponentSuggestions
else empty) $$
text "- To find out which components ghc-mod knows about try:" $$
nest 4 (backticks $ text "ghc-mod debug")
where
noComponentSuggestions =
text "- Are some of these modules part of a test and or benchmark?\
\ Try enabling them:" $$
nest 4 (backticks $ text "cabal configure --enable-tests [--enable-benchmarks]")
backticks d = char '`' <> d <> char '`'
ctxDoc = moduleDoc *** compsDoc
>>> first (<> colon) >>> uncurry (flip hang 4)
moduleDoc (Left fn) =
text "File " <> quotes (text fn)
moduleDoc (Right mdl) =
text "Module " <> quotes (text $ moduleNameString mdl)
compsDoc sc | Set.null sc = text "has no known components"
compsDoc sc = fsep $ punctuate comma $
map gmComponentNameDoc $ Set.toList sc
GMEProcess cmd args emsg -> let c = showCommandForUser cmd args in
case emsg of
Right err ->
text (printf "Launching system command `%s` failed: " c)
<> gmeDoc err
Left (_out, _err, rv) -> text $
printf "Launching system command `%s` failed (exited with %d)" c rv
GMENoCabalFile ->
text "No cabal file found."
GMETooManyCabalFiles cfs ->
text $ "Multiple cabal files found. Possible cabal files: \""
++ intercalate "\", \"" cfs ++"\"."
GMECabalStateFile csfe ->
gmCsfeDoc csfe
ghcExceptionDoc :: GhcException -> Doc
ghcExceptionDoc e@(CmdLineError _) =
text $ "<command line>: " ++ showGhcException e ""
ghcExceptionDoc (UsageError str) = strDoc str
ghcExceptionDoc (Panic msg) = vcat $ map text $ lines $ printf "\
\GHC panic! (the 'impossible' happened)\n\
\ ghc-mod version %s\n\
\ GHC library version %s for %s:\n\
\ %s\n\
\\n\
\Please report this as a bug: %s\n"
gmVer ghcVer platform msg url
where
gmVer = showVersion version
ghcVer = cProjectVersion
platform = cHostPlatformString
url = "https://github.com/kazu-yamamoto/ghc-mod/issues" :: String
ghcExceptionDoc e = text $ showGhcException e ""
liftMaybe :: MonadError e m => e -> m (Maybe a) -> m a
liftMaybe e action = maybe (throwError e) return =<< action
overrideError :: MonadError e m => e -> m a -> m a
overrideError e action = modifyError (const e) action
modifyError :: MonadError e m => (e -> e) -> m a -> m a
modifyError f action = action `catchError` \e -> throwError $ f e
@ -69,6 +175,24 @@ 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
action `catchError` \e -> fix e >> action
tryFix action f = do
action `catchError` \e -> f e >> action
data GHandler m a = forall e . Exception e => GHandler (e -> m a)
gcatches :: (MonadIO m, ExceptionMonad m) => m a -> [GHandler m a] -> m a
gcatches io handlers = io `gcatch` gcatchesHandler handlers
gcatchesHandler :: (MonadIO m, ExceptionMonad m)
=> [GHandler m a] -> SomeException -> m a
gcatchesHandler handlers e = foldr tryHandler (liftIO $ throw e) handlers
where tryHandler (GHandler handler) res
= case fromException e of
Just e' -> handler e'
Nothing -> res

199
Language/Haskell/GhcMod/FillSig.hs
View File

@ -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
where
body = inModuleContext file $ \dflag style -> do
opt <- options
modSum <- Gap.fileModSummary file
whenFound opt (getSignature modSum lineNo colNo) $ \s -> case s of
sig file lineNo colNo =
runGmlT' [Left file] deferErrors $ ghandle fallback $ do
opt <- options
style <- getStyle
dflag <- G.getSessionDynFlags
modSum <- Gap.fileModSummary file
whenFound opt (getSignature modSum lineNo colNo) $ \s ->
case s of
Signature loc names ty ->
("function", fourInts loc, map (initialBody dflag style ty) names)
("function", fourInts loc, map (initialBody dflag style ty) names)
InstanceDecl loc cls ->
("instance", fourInts loc, map (\x -> initialBody dflag style (G.idType x) x)
(Ty.classMethods cls))
let body x = initialBody dflag style (G.idType x) x
in ("instance", fourInts loc, body `map` Ty.classMethods cls)
TyFamDecl loc name flavour vars ->
let (rTy, initial) = initialTyFamString flavour
in (rTy, fourInts loc, [initial ++ initialFamBody dflag style name vars])
handler (SomeException _) = do
body = initialFamBody dflag style name vars
in (rTy, fourInts loc, [initial ++ body])
where
fallback (SomeException _) = do
opt <- options
-- Code cannot be parsed by ghc module
-- Fallback: try to get information via haskell-src-exts
@ -97,7 +111,11 @@ 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
then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)
else fname ++ " " ++ unwords arglist
arglist
| isSymbolName fname ->
head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)
| otherwise ->
fname ++ " " ++ unwords arglist
initialBodyArgs1 :: [FnArg] -> [String] -> [String]
initialBodyArgs1 args elts = take (length args) elts
@ -238,12 +264,24 @@ 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,48 +339,61 @@ 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) =
ghandle handler $
runGmlT' [Left file] deferErrors $ do
opt <- options
style <- getStyle
dflag <- G.getSessionDynFlags
modSum <- Gap.fileModSummary file
p <- G.parseModule modSum
tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
ety <- G.exprType expr
whenFound opt (findVar dflag style tcm tcs lineNo colNo) $
\(loc, name, rty, paren) ->
let eArgs = getFnArgs ety
rArgs = getFnArgs rty
diffArgs' = length eArgs - length rArgs
diffArgs = if diffArgs' < 0 then 0 else diffArgs'
iArgs = take diffArgs eArgs
txt = initialHead1 expr iArgs (infinitePrefixSupply name)
in (fourInts loc, doParen paren txt)
where
body = inModuleContext file $ \dflag style -> do
opt <- options
modSum <- Gap.fileModSummary file
p <- G.parseModule modSum
tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
ety <- G.exprType expr
whenFound opt (findVar dflag style tcm tcs lineNo colNo) $
\(loc, name, rty, paren) ->
let eArgs = getFnArgs ety
rArgs = getFnArgs rty
diffArgs' = length eArgs - length rArgs
diffArgs = if diffArgs' < 0 then 0 else diffArgs'
iArgs = take diffArgs eArgs
text = initialHead1 expr iArgs (infinitePrefixSupply name)
in (fourInts loc, doParen paren text)
handler (SomeException _) = emptyResult =<< options
handler (SomeException ex) = do
gmLog GmDebug "refining" $
text "" $$ nest 4 (showDoc ex)
emptyResult =<< options
-- Look for the variable in the specified position
findVar :: GhcMonad m => DynFlags -> PprStyle
-> G.TypecheckedModule -> G.TypecheckedSource
-> Int -> Int -> m (Maybe (SrcSpan, String, Type, Bool))
findVar
:: GhcMonad m
=> DynFlags
-> PprStyle
-> G.TypecheckedModule
-> G.TypecheckedSource
-> Int
-> Int
-> m (Maybe (SrcSpan, String, Type, Bool))
findVar dflag style tcm tcs lineNo colNo =
let lst = sortBy (cmp `on` G.getLoc) $
listifySpans tcs (lineNo, colNo) :: [G.LHsExpr Id]
in case lst of
e@(L _ (G.HsVar i)):others ->
do tyInfo <- Gap.getType tcm e
let name = getFnName dflag style i
if (name == "undefined" || head name == '_') && isJust tyInfo
then let Just (s,t) = tyInfo
b = case others of -- If inside an App, we need
-- parenthesis
[] -> False
L _ (G.HsApp (L _ a1) (L _ a2)):_ ->
isSearchedVar i a1 || isSearchedVar i a2
_ -> False
in return $ Just (s, name, t, b)
else return Nothing
_ -> return Nothing
case lst of
e@(L _ (G.HsVar i)):others -> do
tyInfo <- Gap.getType tcm e
case tyInfo of
Just (s, typ)
| name == "undefined" || head name == '_' ->
return $ Just (s, name, typ, b)
where
name = getFnName dflag style i
-- If inside an App, we need parenthesis
b = case others of
L _ (G.HsApp (L _ a1) (L _ a2)):_ ->
isSearchedVar i a1 || isSearchedVar i a2
_ -> False
_ -> return Nothing
_ -> return Nothing
where
lst :: [G.LHsExpr Id]
lst = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo)
infinitePrefixSupply :: String -> [String]
infinitePrefixSupply "undefined" = repeat "undefined"
@ -366,10 +417,11 @@ auto :: IOish m
-> Int -- ^ Line number.
-> Int -- ^ Column number.
-> GhcModT m String
auto file lineNo colNo = ghandle handler body
where
body = inModuleContext file $ \dflag style -> do
auto file lineNo colNo =
ghandle handler $ runGmlT' [Left file] deferErrors $ do
opt <- options
style <- getStyle
dflag <- G.getSessionDynFlags
modSum <- Gap.fileModSummary file
p <- G.parseModule modSum
tcm@TypecheckedModule {
@ -395,8 +447,11 @@ 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))
handler (SomeException _) = emptyResult =<< options
where
handler (SomeException ex) = do
gmLog GmDebug "auto-refining" $
text "" $$ nest 4 (showDoc ex)
emptyResult =<< options
-- Functions we do not want in completions
notWantedFuns :: [String]
@ -443,7 +498,11 @@ 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
where getBindingsForRecFields [] = M.empty
getBindingsForRecFields (Ty.HsRecField {Ty.hsRecFieldArg = (L _ a)}:fs) =
M.union (getBindingsForPat a) (getBindingsForRecFields fs)
getBindingsForRecFields (map unLoc' fields)
where
#if __GLASGOW_HASKELL__ >= 710
unLoc' = unLoc
#else
unLoc' = id
#endif
getBindingsForRecFields [] = M.empty
getBindingsForRecFields (Ty.HsRecField {Ty.hsRecFieldArg = (L _ a)}:fs) =
M.union (getBindingsForPat a) (getBindingsForRecFields fs)

147
Language/Haskell/GhcMod/Find.hs
View File

@ -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 {
table :: Map Symbol [ModuleString]
, packageCachePath :: FilePath
data SymbolDb = SymbolDb
{ table :: Map Symbol [ModuleString]
, symbolDbCachePath :: FilePath
} deriving (Show)
isOutdated :: SymbolDb -> IO Bool
isOutdated db = symbolDbCachePath db `isOlderThan` packageCachePath db
----------------------------------------------------------------
-- | When introducing incompatible changes to the 'symbolCache' file format
-- increment this version number.
symbolCacheVersion :: Integer
symbolCacheVersion = 0
-- | Filename of the symbol table cache file.
symbolCache :: String
symbolCache = "ghc-mod-"++ show symbolCacheVersion ++".cache"
isOutdated :: IOish m => SymbolDb -> GhcModT m Bool
isOutdated db =
(liftIO . isOlderThan (symbolDbCachePath db)) =<< timedPackageCaches
----------------------------------------------------------------
-- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]
-- which will be concatenated. 'loadSymbolDb' is called internally.
findSymbol :: IOish m => Symbol -> GhcModT m String
findSymbol sym = loadSymbolDb >>= lookupSymbol sym
findSymbol sym = do
tmpdir <- cradleTempDir <$> cradle
loadSymbolDb tmpdir >>= lookupSymbol sym
-- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]
-- which will be concatenated.
@ -81,25 +66,25 @@ lookupSymbol :: 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 = do
ghcMod <- liftIO ghcModExecutable
tmpdir <- cradleTempDir <$> cradle
file <- chop <$> readProcess' ghcMod ["dumpsym", tmpdir]
!db <- M.fromAscList . map conv . lines <$> liftIO (readFile file)
return $ SymbolDb {
table = db
, packageCachePath = takeDirectory file </> packageCache
, symbolDbCachePath = file
}
loadSymbolDb :: IOish m => FilePath -> GhcModT m SymbolDb
loadSymbolDb dir = do
ghcMod <- liftIO ghcModExecutable
readProc <- gmReadProcess
file <- liftIO $ chop <$> readProc ghcMod ["dumpsym", dir] ""
!db <- M.fromAscList . map conv . lines <$> liftIO (readFile file)
return $ SymbolDb
{ table = db
, symbolDbCachePath = file
}
where
conv :: String -> (Symbol,[ModuleString])
conv :: String -> (Symbol, [ModuleString])
conv = read
chop :: String -> String
chop "" = ""
chop xs = init xs
@ -112,54 +97,52 @@ loadSymbolDb = do
dumpSymbol :: IOish m => FilePath -> GhcModT m String
dumpSymbol dir = do
let cache = dir </> symbolCache
pkgdb = dir </> packageCache
create <- liftIO $ cache `isOlderThan` pkgdb
when create $ (liftIO . writeSymbolCache cache) =<< getSymbolTable
create <- (liftIO . isOlderThan cache) =<< timedPackageCaches
runGmPkgGhc $ do
when create $
liftIO . writeSymbolCache cache =<< getGlobalSymbolTable
return $ unlines [cache]
where
cache = dir </> symbolCacheFile
writeSymbolCache :: FilePath
-> [(Symbol,[ModuleString])]
-> [(Symbol, [ModuleString])]
-> IO ()
writeSymbolCache cache sm =
void . withFile cache WriteMode $ \hdl ->
mapM (hPrint hdl) sm
mapM (hPrint hdl) sm
isOlderThan :: FilePath -> FilePath -> IO Bool
isOlderThan cache file = do
exist <- doesFileExist cache
if not exist then
return True
else do
tCache <- getModificationTime cache
tFile <- getModificationTime file
return $ tCache <= tFile -- including equal just in case
-- | Check whether given file is older than any file from the given set.
-- Returns True if given file does not exist.
isOlderThan :: FilePath -> [TimedFile] -> IO Bool
isOlderThan cache files = do
exist <- doesFileExist cache
if not exist
then return True
else do
tCache <- getModificationTime cache
return $ any (tCache <=) $ map tfTime files -- including equal just in case
-- | Browsing all functions in all system/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` mods)
return $ collectModules
$ extractBindings `concatMap` (moduleInfos `zip` modules)
extractBindings :: (Maybe G.ModuleInfo, ModuleString)
extractBindings :: (Maybe G.ModuleInfo, G.Module)
-> [(Symbol, ModuleString)]
extractBindings (Nothing,_) = []
extractBindings (Just inf,mdlname) =
map (\name -> (getOccString name, mdlname)) names
extractBindings (Nothing, _) = []
extractBindings (Just inf, mdl) =
map (\name -> (getOccString name, modStr)) names
where
names = G.modInfoExports inf
names = G.modInfoExports inf
modStr = ModuleString $ moduleNameString $ moduleName mdl
collectModules :: [(Symbol,ModuleString)]
-> [(Symbol,[ModuleString])]
collectModules :: [(Symbol, ModuleString)]
-> [(Symbol, [ModuleString])]
collectModules = map tieup . groupBy ((==) `on` fst) . sort
where
tieup x = (head (map fst x), map snd x)

86
Language/Haskell/GhcMod/GHCApi.hs
View File

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

23
Language/Haskell/GhcMod/GHCChoice.hs
View File

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

172
Language/Haskell/GhcMod/Gap.hs
View File

@ -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 str = do
infoThing :: GhcMonad m => Expression -> m SDoc
infoThing (Expression str) = do
names <- parseName str
#if __GLASGOW_HASKELL__ >= 708
mb_stuffs <- mapM (getInfo False) names
@ -413,29 +431,6 @@ 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__ >= 708
setFlags df = df `gopt_unset` Opt_SpecConstr -- consume memory if -O2
#else
setFlags = id
#if __GLASGOW_HASKELL__ < 710
-- Copied from ghc/InteractiveUI.hs
allExposedPackageConfigs :: DynFlags -> [PackageConfig]
allExposedPackageConfigs df = filter exposed $ eltsUFM $ pkgIdMap $ pkgState df
allExposedModules :: DynFlags -> [ModuleName]
allExposedModules df = concat $ map exposedModules $ allExposedPackageConfigs df
listVisibleModuleNames :: DynFlags -> [ModuleName]
listVisibleModuleNames = allExposedModules
#endif
lookupModulePackageInAllPackages ::
DynFlags -> ModuleName -> [String]
lookupModulePackageInAllPackages df mn =
#if __GLASGOW_HASKELL__ >= 710
unpackSPId . sourcePackageId . snd <$> lookupModuleInAllPackages df mn
where
unpackSPId (SourcePackageId fs) = unpackFS fs
#else
unpackPId . sourcePackageId . fst <$> lookupModuleInAllPackages df mn
where
unpackPId pid = packageIdString $ mkPackageId pid
-- n ++ "-" ++ showVersion v
#endif
listVisibleModules :: DynFlags -> [GHC.Module]
listVisibleModules df = let
#if __GLASGOW_HASKELL__ >= 710
modNames = listVisibleModuleNames df
mods = [ m | mn <- modNames, (m, _) <- lookupModuleInAllPackages df mn ]
#else
pkgCfgs = allExposedPackageConfigs df
mods = [ mkModule pid modname | p <- pkgCfgs
, let pid = packageConfigId p
, modname <- exposedModules p ]
#endif
in mods
isSynTyCon :: TyCon -> Bool
#if __GLASGOW_HASKELL__ >= 710
isSynTyCon = GHC.isTypeSynonymTyCon
#else
isSynTyCon = GHC.isSynTyCon
#endif
parseModuleHeader
:: String -- ^ Haskell module source text (full Unicode is supported)
-> DynFlags
-> FilePath -- ^ the filename (for source locations)
-> Either ErrorMessages (WarningMessages, Located (HsModule RdrName))
parseModuleHeader str dflags filename =
let
loc = mkRealSrcLoc (mkFastString filename) 1 1
buf = stringToStringBuffer str
in
case L.unP Parser.parseHeader (mkPState dflags buf loc) of
PFailed sp err ->
#if __GLASGOW_HASKELL__ >= 706
Left (unitBag (mkPlainErrMsg dflags sp err))
#else
Left (unitBag (mkPlainErrMsg sp err))
#endif
POk pst rdr_module ->
let (warns,_) = getMessages pst in
Right (warns, rdr_module)

61
Language/Haskell/GhcMod/GhcPkg.hs
View File

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

263
Language/Haskell/GhcMod/HomeModuleGraph.hs Normal file
View File

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

74
Language/Haskell/GhcMod/Info.hs
View File

@ -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
opt <- options
convert opt <$> ghandle handler body
info file expr =
ghandle handler $
runGmlT' [Left file] deferErrors $
withContext $
convert <$> options <*> body
where
body = inModuleContext file $ \dflag style -> do
sdoc <- Gap.infoThing expr
return $ showPage dflag style sdoc
handler (SomeException _) = return "Cannot show info"
handler (SomeException ex) = do
gmLog GmException "info" $ text "" $$ nest 4 (showDoc ex)
convert' "Cannot show info"
body :: GhcMonad m => m String
body = do
sdoc <- Gap.infoThing expr
st <- getStyle
dflag <- G.getSessionDynFlags
return $ showPage dflag st sdoc
----------------------------------------------------------------
@ -42,24 +55,29 @@ types :: IOish m
-> Int -- ^ Line number.
-> Int -- ^ Column number.
-> GhcModT m String
types file lineNo colNo = do
opt <- options
convert opt <$> ghandle handler body
where
body = inModuleContext file $ \dflag style -> do
modSum <- Gap.fileModSummary file
types file lineNo colNo =
ghandle handler $
runGmlT' [Left file] deferErrors $
withContext $ do
crdl <- cradle
modSum <- Gap.fileModSummary (cradleCurrentDir crdl </> file)
srcSpanTypes <- getSrcSpanType modSum lineNo colNo
return $ map (toTup dflag style) $ sortBy (cmp `on` fst) srcSpanTypes
handler (SomeException _) = return []
dflag <- G.getSessionDynFlags
st <- getStyle
convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes
where
handler (SomeException ex) = do
gmLog GmException "types" $ showDoc ex
return []
getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)]
getSrcSpanType modSum lineNo colNo = do
p <- G.parseModule modSum
tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id]
es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id]
ps = listifySpans tcs (lineNo, colNo) :: [LPat Id]
bts <- mapM (getType tcm) bs
ets <- mapM (getType tcm) es
pts <- mapM (getType tcm) ps
return $ catMaybes $ concat [ets, bts, pts]
p <- G.parseModule modSum
tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id]
es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id]
ps = listifySpans tcs (lineNo, colNo) :: [LPat Id]
bts <- mapM (getType tcm) bs
ets <- mapM (getType tcm) es
pts <- mapM (getType tcm) ps
return $ catMaybes $ concat [ets, bts, pts]

45
Language/Haskell/GhcMod/Internal.hs
View File

@ -8,35 +8,33 @@ module Language.Haskell.GhcMod.Internal (
, PackageVersion
, PackageId
, IncludeDir
, CompilerOptions(..)
-- * Cabal API
, parseCabalFile
, getCompilerOptions
, cabalAllBuildInfo
, cabalDependPackages
, cabalSourceDirs
, cabalAllTargets
, GmlT(..)
, MonadIO(..)
, GmEnv(..)
-- * Various Paths
, ghcLibDir
, ghcModExecutable
-- * IO
, getDynamicFlags
-- * Targets
, setTargetFiles
-- * Logging
, withLogger
, setNoWarningFlags
, setAllWarningFlags
-- * Environment, state and logging
, GhcModEnv(..)
, newGhcModEnv
, GhcModState
, defaultState
, CompilerMode(..)
, GhcModLog
, GmLog(..)
, GmLogLevel(..)
, gmSetLogLevel
-- * Monad utilities
, runGhcModT'
, hoistGhcModT
, runGmlT
, runGmlT'
, gmlGetSession
, gmlSetSession
, loadTargets
, cabalResolvedComponents
-- ** Accessing 'GhcModEnv' and 'GhcModState'
, options
, cradle
@ -45,28 +43,33 @@ 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

234
Language/Haskell/GhcMod/Logger.hs
View File

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

102
Language/Haskell/GhcMod/Logging.hs Normal file
View File

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

40
Language/Haskell/GhcMod/Modules.hs
View File

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

514
Language/Haskell/GhcMod/Monad.hs
View File

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

442
Language/Haskell/GhcMod/Monad/Types.hs Normal file
View File

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

199
Language/Haskell/GhcMod/Output.hs Normal file
View File

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

203
Language/Haskell/GhcMod/PathsAndFiles.hs
View File

@ -1,21 +1,42 @@
{-# LANGUAGE BangPatterns, TupleSections #-}
module Language.Haskell.GhcMod.PathsAndFiles where
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
module Language.Haskell.GhcMod.PathsAndFiles (
module Language.Haskell.GhcMod.PathsAndFiles
, module Language.Haskell.GhcMod.Caching
) where
import Config (cProjectVersion)
import Control.Applicative
import Control.Monad
import Data.List
import Data.Char
import Data.Maybe
import Data.Traversable (traverse)
import Language.Haskell.GhcMod.Types
import Data.Traversable hiding (mapM)
import Distribution.Helper (buildPlatform)
import System.Directory
import System.FilePath
import System.Process
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.Caching
import qualified Language.Haskell.GhcMod.Utils as U
import Distribution.Simple.BuildPaths (defaultDistPref)
import Distribution.Simple.Configure (localBuildInfoFile)
import Utils (mightExist)
import Prelude
-- | Guaranteed to be a path to a directory with no trailing slash.
type DirPath = FilePath
@ -23,40 +44,111 @@ 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
-- Look for cabal files in @dir@ and all it's parent directories
dcs <- getCabalFiles `zipMapM` parents directory
-- Extract first non-empty list, which represents a directory with cabal
-- files.
case find (not . null) $ uncurry appendDir `map` dcs of
Just [] -> throw $ GMENoCabalFile
findCabalFile dir = do
-- List of directories and all cabal file candidates
dcs <- findFileInParentsP isCabalFile dir :: IO ([(DirPath, [FileName])])
let css = uncurry appendDir `map` dcs :: [[FilePath]]
case find (not . null) css of
Nothing -> return Nothing
Just cfs@(_:_:_) -> throw $ GMETooManyCabalFiles cfs
a -> return $ head <$> a
Just (a:_) -> return (Just a)
Just [] -> error "findCabalFile"
where
appendDir :: DirPath -> [FileName] -> [FilePath]
appendDir dir fs = (dir </>) `map` fs
appendDir d fs = (d </>) `map` fs
-- | 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
exists <- doesFileExist $ dir </> f
return (exists && takeExtension' f == ".cabal")
fixPkgDbVer bp dir =
case takeFileName dir == ghcSandboxPkgDbDir bp of
True -> dir
False -> takeDirectory dir </> ghcSandboxPkgDbDir bp
takeExtension' p = if takeFileName p == takeExtension p
then ""
else takeExtension p
-- | Extract the sandbox package db directory from the cabal.sandbox.config
-- file. Exception is thrown if the sandbox config file is broken.
extractSandboxDbDir :: String -> Maybe FilePath
extractSandboxDbDir conf = extractValue <$> parse conf
where
key = "package-db:"
keyLen = length key
parse = listToMaybe . filter (key `isPrefixOf`) . lines
extractValue = U.dropWhileEnd isSpace . dropWhile isSpace . drop keyLen
-- |
-- >>> isCabalFile "/home/user/.cabal"
-- False
isCabalFile :: FilePath -> Bool
isCabalFile f = takeExtension' f == ".cabal"
-- |
-- >>> takeExtension' "/some/dir/bla.cabal"
-- ".cabal"
--
-- >>> takeExtension' "some/reldir/bla.cabal"
-- ".cabal"
--
-- >>> takeExtension' "bla.cabal"
-- ".cabal"
--
-- >>> takeExtension' ".cabal"
-- ""
takeExtension' :: FilePath -> String
takeExtension' p =
if takeFileName p == takeExtension p
then "" -- just ".cabal" is not a valid cabal file
else takeExtension p
-- | @findFileInParentsP p dir@ Look for files satisfying @p@ in @dir@ and all
-- it's parent directories.
findFileInParentsP :: (FilePath -> Bool) -> FilePath
-> IO [(DirPath, [FileName])]
findFileInParentsP p dir =
getFilesP p `zipMapM` parents dir
-- | @getFilesP p dir@. Find all __files__ satisfying @p@ in @.cabal@ in @dir@.
getFilesP :: (FilePath -> Bool) -> DirPath -> IO [FileName]
getFilesP p dir = filterM p' =<< getDirectoryContents dir
where
p' fn = do
(p fn && ) <$> doesFileExist (dir </> fn)
findCabalSandboxDir :: FilePath -> IO (Maybe FilePath)
findCabalSandboxDir dir = do
dss <- findFileInParentsP isSandboxConfig dir
return $ case find (not . null . snd) $ dss of
Just (sbDir, _:_) -> Just sbDir
_ -> Nothing
where
isSandboxConfig = (==sandboxConfigFile)
zipMapM :: Monad m => (a -> m c) -> [a] -> m [(a,c)]
zipMapM f as = mapM (\a -> liftM (a,) $ f a) as
zipMapM f as = mapM (\a -> liftM ((,) a) $ f a) as
-- | @parents dir@. Returns all parent directories of @dir@ including @dir@.
--
@ -86,31 +178,48 @@ 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

17
Language/Haskell/GhcMod/PkgDoc.hs
View File

@ -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
pkg <- trim <$> readProcess' "ghc-pkg" (toModuleOpts c)
pkgDbStack <- getPackageDbStack
pkg <- liftIO $ trim <$> readProcess "ghc-pkg" (toModuleOpts pkgDbStack) ""
if pkg == "" then
return "\n"
else do
htmlpath <- readProcess' "ghc-pkg" (toDocDirOpts pkg c)
htmlpath <- liftIO $ readProcess "ghc-pkg" (toDocDirOpts pkg pkgDbStack) ""
let ret = pkg ++ " " ++ drop 14 htmlpath
return ret
where
toModuleOpts c = ["find-module", mdl, "--simple-output"]
++ ghcPkgDbStackOpts (cradlePkgDbStack c)
toDocDirOpts pkg c = ["field", pkg, "haddock-html"]
++ ghcPkgDbStackOpts (cradlePkgDbStack c)
toModuleOpts dbs = ["find-module", mdl, "--simple-output"]
++ ghcPkgDbStackOpts dbs
toDocDirOpts pkg dbs = ["field", pkg, "haddock-html"]
++ ghcPkgDbStackOpts dbs
trim = takeWhile (`notElem` " \n")

69
Language/Haskell/GhcMod/Pretty.hs Normal file
View File

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

26
Language/Haskell/GhcMod/SrcUtils.hs
View File

@ -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.DynFlags
import Language.Haskell.GhcMod.Gap (HasType(..), setWarnTypedHoles, setDeferTypeErrors)
import Language.Haskell.GhcMod.Doc
import Language.Haskell.GhcMod.Gap
import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Monad (IOish, GhcModT)
import Language.Haskell.GhcMod.Target (setTargetFiles)
import OccName (OccName)
import Outputable (PprStyle)
import TcHsSyn (hsPatType)
import Prelude
----------------------------------------------------------------
@ -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

502
Language/Haskell/GhcMod/Target.hs
View File

@ -1,60 +1,486 @@
{-# LANGUAGE CPP #-}
module Language.Haskell.GhcMod.Target (
setTargetFiles
) where
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# 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 ()
setTargetFiles files = do
targets <- forM files $ \file -> G.guessTarget file Nothing
G.setTargets targets
loadTargets :: IOish m => [String] -> GmlT m ()
loadTargets filesOrModules = do
gmLog GmDebug "loadTargets" $
text "Loading" <+>: fsep (map text filesOrModules)
targets <- forM filesOrModules (flip guessTarget Nothing)
setTargets targets
mode <- getCompilerMode
if mode == Intelligent then
loadTargets Intelligent
if mode == Intelligent
then loadTargets' Intelligent
else do
mdls <- G.depanal [] False
mdls <- depanal [] False
let fallback = needsFallback mdls
if fallback then do
resetTargets targets
setIntelligent
loadTargets Intelligent
gmLog GmInfo "loadTargets" $
text "Target needs interpeter, switching to LinkInMemory/HscInterpreted. Perfectly normal if anything is using TemplateHaskell, QuasiQuotes or PatternSynonyms."
loadTargets' Intelligent
else
loadTargets Simple
loadTargets' Simple
where
loadTargets Simple = do
-- Reporting error A and error B
void $ G.load LoadAllTargets
mss <- filter (\x -> G.ms_hspp_file x `elem` files) <$> G.getModuleGraph
-- Reporting error B and error C
mapM_ (G.parseModule >=> G.typecheckModule >=> G.desugarModule) mss
-- Error B duplicates. But we cannot ignore both error reportings,
-- sigh. So, the logger makes log messages unique by itself.
loadTargets Intelligent = do
df <- G.getSessionDynFlags
void $ G.setSessionDynFlags (setModeIntelligent df)
void $ G.load LoadAllTargets
loadTargets' Simple = do
void $ load LoadAllTargets
mapM_ (parseModule >=> typecheckModule >=> desugarModule) =<< getModuleGraph
loadTargets' Intelligent = do
df <- getSessionDynFlags
void $ setSessionDynFlags (setModeIntelligent df)
void $ load LoadAllTargets
resetTargets targets = do
G.setTargets []
void $ G.load LoadAllTargets
G.setTargets targets
setTargets []
void $ load LoadAllTargets
setTargets targets
setIntelligent = do
newdf <- setModeIntelligent <$> G.getSessionDynFlags
void $ G.setSessionDynFlags newdf
newdf <- setModeIntelligent <$> getSessionDynFlags
void $ setSessionDynFlags newdf
setCompilerMode Intelligent
needsFallback :: G.ModuleGraph -> Bool
needsFallback :: ModuleGraph -> Bool
needsFallback = any $ \ms ->
let df = G.ms_hspp_opts ms in
let df = ms_hspp_opts ms in
Opt_TemplateHaskell `xopt` df
|| Opt_QuasiQuotes `xopt` df
#if __GLASGOW_HASKELL__ >= 708
|| (Opt_PatternSynonyms `xopt` df)
#endif
cabalResolvedComponents :: (IOish m) =>
GhcModT m (Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath)))
cabalResolvedComponents = do
crdl@(Cradle{..}) <- cradle
comps <- mapM (resolveEntrypoint crdl) =<< getComponents
cached cradleRootDir resolvedComponentsCache comps

333
Language/Haskell/GhcMod/Types.hs
View File

@ -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,44 +95,114 @@ data Options = Options {
, hlintOpts :: [String]
} deriving (Show)
-- | A default 'Options'.
defaultOptions :: Options
defaultOptions = Options {
outputStyle = PlainStyle
, hlintOpts = []
, ghcProgram = "ghc"
, cabalProgram = "cabal"
, ghcUserOptions= []
, operators = False
, detailed = False
, qualified = False
, lineSeparator = LineSeparator "\0"
outputStyle = PlainStyle
, lineSeparator = LineSeparator "\0"
, linePrefix = Nothing
, logLevel = GmWarning
, ghcProgram = "ghc"
, ghcPkgProgram = "ghc-pkg"
, cabalProgram = "cabal"
, ghcUserOptions = []
, operators = False
, detailed = False
, qualified = False
, hlintOpts = []
}
----------------------------------------------------------------
data ProjectType = CabalProject | SandboxProject | PlainProject
deriving (Eq, Show)
-- | The environment where this library is used.
data Cradle = Cradle {
cradleProjectType:: ProjectType
-- | The directory where this library is executed.
cradleCurrentDir :: FilePath
, cradleCurrentDir :: FilePath
-- | The project root directory.
, cradleRootDir :: FilePath
-- | Per-Project temporary directory
, cradleTempDir :: FilePath
-- | The file name of the found cabal file.
, cradleCabalFile :: Maybe FilePath
-- | Package database stack
, cradlePkgDbStack :: [GhcPkgDb]
} deriving (Eq, Show)
data GmStream = GmOut | GmErr
deriving (Show)
data GmLineType = GmTerminated | GmPartial
deriving (Show)
data GmLines a = GmLines GmLineType a
deriving (Show, Functor)
unGmLine :: GmLines a -> a
unGmLine (GmLines _ s) = s
data GmOutput = GmOutputStdio
| GmOutputChan (Chan (GmStream, GmLines String))
data GhcModEnv = GhcModEnv {
gmOptions :: Options
, gmCradle :: Cradle
, gmOutput :: GmOutput
}
data GhcModLog = GhcModLog {
gmLogLevel :: Maybe GmLogLevel,
gmLogVomitDump :: Last Bool,
gmLogMessages :: [(GmLogLevel, String, Doc)]
} deriving (Show)
instance Monoid GhcModLog where
mempty = GhcModLog (Just GmPanic) (Last Nothing) mempty
GhcModLog ml vd ls `mappend` GhcModLog ml' vd' ls' =
GhcModLog (ml' `mplus` ml) (vd `mappend` vd') (ls `mappend` ls')
data GmGhcSession = GmGhcSession {
gmgsOptions :: ![GHCOption],
gmgsSession :: !(IORef HscEnv)
}
data GhcModCaches = GhcModCaches {
gmcPackageDbStack :: CacheContents ChCacheData [GhcPkgDb]
, gmcMergedPkgOptions :: CacheContents ChCacheData [GHCOption]
, gmcComponents :: CacheContents ChCacheData [GmComponent 'GMCRaw ChEntrypoint]
, gmcResolvedComponents :: CacheContents
[GmComponent 'GMCRaw (Set.Set ModulePath)]
(Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath)))
}
data GhcModState = GhcModState {
gmGhcSession :: !(Maybe GmGhcSession)
, gmComponents :: !(Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath)))
, gmCompilerMode :: !CompilerMode
, gmCaches :: !GhcModCaches
}
data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read)
defaultGhcModState :: GhcModState
defaultGhcModState =
GhcModState n Map.empty Simple (GhcModCaches n n n n)
where n = Nothing
----------------------------------------------------------------
-- | GHC package database flags.
data GhcPkgDb = GlobalDb | UserDb | PackageDb String deriving (Eq, Show)
data GhcPkgDb = GlobalDb
| UserDb
| PackageDb String
deriving (Eq, Show, Generic)
instance Serialize GhcPkgDb
-- | A single GHC command line option.
type GHCOption = String
type GHCOption = String
-- | An include directory for modules.
type IncludeDir = FilePath
@ -89,44 +211,175 @@ type IncludeDir = FilePath
type PackageBaseName = String
-- | A package version.
type PackageVersion = String
type PackageVersion = String
-- | A package id.
type PackageId = String
type PackageId = String
-- | A package's name, verson and id.
type Package = (PackageBaseName, PackageVersion, PackageId)
type Package = (PackageBaseName, PackageVersion, PackageId)
pkgName :: Package -> PackageBaseName
pkgName (n,_,_) = n
pkgName (n, _, _) = n
pkgVer :: Package -> PackageVersion
pkgVer (_,v,_) = v
pkgVer (_, v, _) = v
pkgId :: Package -> PackageId
pkgId (_,_,i) = i
pkgId (_, _, i) = i
showPkg :: Package -> String
showPkg (n,v,_) = intercalate "-" [n,v]
showPkg (n, v, _) = intercalate "-" [n, v]
showPkgId :: Package -> String
showPkgId (n,v,i) = intercalate "-" [n,v,i]
-- | Collection of packages
type PkgDb = (M.Map Package PackageConfig)
showPkgId (n, v, i) = intercalate "-" [n, v, i]
-- | Haskell expression.
type Expression = String
newtype Expression = Expression { getExpression :: String }
deriving (Show, Eq, Ord)
-- | Module name.
type ModuleString = String
newtype ModuleString = ModuleString { getModuleString :: String }
deriving (Show, Read, Eq, Ord)
-- | A Module
type Module = [String]
data GmLogLevel =
GmSilent
| GmPanic
| GmException
| GmError
| GmWarning
| GmInfo
| GmDebug
| GmVomit
deriving (Eq, Ord, Enum, Bounded, Show, Read)
-- | Option information for GHC
data CompilerOptions = CompilerOptions {
ghcOptions :: [GHCOption] -- ^ Command line options
, includeDirs :: [IncludeDir] -- ^ Include directories for modules
, depPackages :: [Package] -- ^ Dependent package names
} deriving (Eq, Show)
-- | Collection of packages
type PkgDb = (Map Package PackageConfig)
data GmModuleGraph = GmModuleGraph {
gmgGraph :: Map ModulePath (Set ModulePath)
} deriving (Eq, Ord, Show, Read, Generic, Typeable)
instance Serialize GmModuleGraph where
put GmModuleGraph {..} = put (mpim, graph)
where
mpim :: Map ModulePath Integer
mpim = Map.fromList $ Map.keys gmgGraph `zip` [0..]
graph :: Map Integer (Set Integer)
graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph
mpToInt :: ModulePath -> Integer
mpToInt mp = fromJust $ Map.lookup mp mpim
get = do
(mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get
let impm = swapMap mpim
intToMp i = fromJust $ Map.lookup i impm
mpGraph :: Map ModulePath (Set ModulePath)
mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph
return $ GmModuleGraph mpGraph
where
swapMap :: (Ord k, Ord v) => Map k v -> Map v k
swapMap = Map.fromList . map (\(x, y) -> (y, x)) . Map.toList
instance Monoid GmModuleGraph where
mempty = GmModuleGraph mempty
mappend (GmModuleGraph a) (GmModuleGraph a') =
GmModuleGraph (Map.unionWith Set.union a a')
data GmComponentType = GMCRaw
| GMCResolved
data GmComponent (t :: GmComponentType) eps = GmComponent {
gmcHomeModuleGraph :: GmModuleGraph
, gmcName :: ChComponentName
, gmcGhcOpts :: [GHCOption]
, gmcGhcPkgOpts :: [GHCOption]
, gmcGhcSrcOpts :: [GHCOption]
, gmcGhcLangOpts :: [GHCOption]
, gmcRawEntrypoints :: ChEntrypoint
, gmcEntrypoints :: eps
, gmcSourceDirs :: [FilePath]
} deriving (Eq, Ord, Show, Read, Generic, Functor)
instance Serialize eps => Serialize (GmComponent t eps)
data ModulePath = ModulePath { mpModule :: ModuleName, mpPath :: FilePath }
deriving (Eq, Ord, Show, Read, Generic, Typeable)
instance Serialize ModulePath
instance Serialize ModuleName where
get = mkModuleName <$> get
put mn = put (moduleNameString mn)
instance Show ModuleName where
show mn = "ModuleName " ++ show (moduleNameString mn)
instance Read ModuleName where
readsPrec d =
readParen
(d > app_prec)
(\r' -> [ (mkModuleName m, t)
| ("ModuleName", s) <- lex r'
, (m, t) <- readsPrec (app_prec + 1) s
])
where
app_prec = 10
data GhcModError
= GMENoMsg
-- ^ Unknown error
| GMEString String
-- ^ Some Error with a message. These are produced mostly by
-- 'fail' calls on GhcModT.
| GMECabalConfigure GhcModError
-- ^ Configuring a cabal project failed.
| GMECabalFlags GhcModError
-- ^ Retrieval of the cabal configuration flags failed.
| GMECabalComponent ChComponentName
-- ^ Cabal component could not be found
| GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)]
-- ^ Could not find a consistent component assignment for modules
| GMEProcess String [String] (Either (String, String, Int) GhcModError)
-- ^ Launching an operating system process failed. Fields in
-- order: command, arguments, (stdout, stderr, exitcode)
| GMENoCabalFile
-- ^ No cabal file found.
| GMETooManyCabalFiles [FilePath]
-- ^ Too many cabal files found.
| GMECabalStateFile GMConfigStateFileError
-- ^ Reading Cabal's state configuration file falied somehow.
deriving (Eq,Show,Typeable)
instance Error GhcModError where
noMsg = GMENoMsg
strMsg = GMEString
instance Exception GhcModError
data GMConfigStateFileError
= GMConfigStateFileNoHeader
| GMConfigStateFileBadHeader
| GMConfigStateFileNoParse
| GMConfigStateFileMissing
-- | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo)
deriving (Eq, Show, Read, Typeable)
deriving instance Generic Version
instance Serialize Version
instance Serialize Programs
instance Serialize ChModuleName
instance Serialize ChComponentName
instance Serialize ChEntrypoint
mkLabel ''GhcModCaches
mkLabel ''GhcModState

199
Language/Haskell/GhcMod/Utils.hs
View File

@ -1,94 +1,159 @@
{-# LANGUAGE CPP #-}
module Language.Haskell.GhcMod.Utils where
-- ghc-mod: Making Haskell development *more* fun
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
import Control.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 System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist)
import System.Exit (ExitCode(..))
import System.Process (readProcessWithExitCode)
import System.Directory (getTemporaryDirectory)
import System.FilePath (splitDrive, pathSeparators)
import System.IO.Temp (createTempDirectory)
#ifndef SPEC
import Control.Applicative ((<$>))
import Language.Haskell.GhcMod.Monad.Types
import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist,
getTemporaryDirectory, canonicalizePath)
import System.Environment
import System.FilePath ((</>),takeDirectory)
#endif
import System.FilePath (splitDrive, takeDirectory, takeFileName, pathSeparators,
(</>))
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)
(\_ -> liftIO (setCurrentDirectory dir) >> action)
gbracket
(liftIO getCurrentDirectory)
(liftIO . setCurrentDirectory)
(\_ -> liftIO (setCurrentDirectory dir) >> action)
uniqTempDirName :: FilePath -> FilePath
uniqTempDirName dir = ("ghc-mod"++) $ uncurry (++)
$ map escapeDriveChar *** map escapePathChar
$ splitDrive dir
where
uniqTempDirName dir =
"ghc-mod" ++ map escapeDriveChar drive ++ map escapePathChar path
where
(drive, path) = splitDrive dir
escapeDriveChar :: Char -> Char
escapeDriveChar c
| isAlphaNum c = c
| otherwise = '-'
| isAlphaNum c = c
| otherwise = '-'
escapePathChar :: Char -> Char
escapePathChar c
| c `elem` pathSeparators = '-'
| otherwise = c
| c `elem` pathSeparators = '-'
| otherwise = c
newTempDir :: FilePath -> IO FilePath
newTempDir dir =
flip createTempDirectory (uniqTempDirName dir) =<< getTemporaryDirectory
flip createTempDirectory (uniqTempDirName dir) =<< getTemporaryDirectory
mightExist :: FilePath -> IO (Maybe FilePath)
mightExist f = do
exists <- doesFileExist f
return $ if exists then (Just f) else (Nothing)
whenM :: Monad m => m Bool -> m () -> m ()
whenM mb ma = mb >>= flip when ma
-- | Returns the path to the currently running ghc-mod executable. With ghc<7.6
-- this is a guess but >=7.6 uses 'getExecutablePath'.
ghcModExecutable :: IO FilePath
#ifndef SPEC
ghcModExecutable = do
dir <- getExecutablePath'
return $ dir </> "ghc-mod"
where
getExecutablePath' :: IO FilePath
# if __GLASGOW_HASKELL__ >= 706
getExecutablePath' = takeDirectory <$> getExecutablePath
# else
getExecutablePath' = return ""
# endif
dir <- takeDirectory <$> getExecutablePath'
return $ (if dir == "." then "" else dir) </> "ghc-mod"
#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

87
Language/Haskell/GhcMod/World.hs
View File

@ -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 System.Directory (getModificationTime)
import Data.Traversable hiding (mapM)
import System.FilePath ((</>))
import GHC.Paths (libdir)
#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
import Prelude
data World = World {
worldPackageCaches :: [TimedFile]
, worldCabalFile :: Maybe TimedFile
, worldCabalConfig :: Maybe TimedFile
, worldSymbolCache :: Maybe TimedFile
} deriving (Eq, Show)
timedPackageCache :: Cradle -> IO [TimedFile]
timedPackageCache crdl = do
fs <- mapM mightExist . map (</> packageCache)
=<< getPackageCachePaths libdir crdl
timeFile `mapM` catMaybes fs
timedPackageCaches :: IOish m => GhcModT m [TimedFile]
timedPackageCaches = do
fs <- mapM (liftIO . mightExist) . map (</> packageCache)
=<< getPackageCachePaths libdir
(liftIO . timeFile) `mapM` catMaybes fs
getCurrentWorld :: Cradle -> IO World
getCurrentWorld crdl = do
pkgCaches <- timedPackageCache crdl
mCabalFile <- timeFile `traverse` cradleCabalFile crdl
mSetupConfig <- mightExist (setupConfigFile crdl)
mCabalConfig <- timeFile `traverse` mSetupConfig
getCurrentWorld :: IOish m => GhcModT m World
getCurrentWorld = do
crdl <- cradle
pkgCaches <- timedPackageCaches
mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl
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 world crdl = do
(world /=) <$> getCurrentWorld crdl
didWorldChange :: IOish m => World -> GhcModT m Bool
didWorldChange world = do
(world /=) <$> getCurrentWorld
-- * 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 :: Cradle -> IO Bool
isSetupConfigOutOfDate crdl = do
world <- getCurrentWorld crdl
return $ worldCabalConfig world < worldCabalFile world
isYoungerThanSetupConfig :: FilePath -> World -> IO Bool
isYoungerThanSetupConfig file World {..} = do
tfile <- timeFile file
return $ worldCabalConfig < Just tfile

27
Language/Haskell/GhcMod/Cabal16.hs → NotCPP/COPYING
View File

@ -1,9 +1,9 @@
-- Copyright : Isaac Jones 2003-2004
{- All rights reserved.
Copyright Ben Millwood 2012
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
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.
@ -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. -}
-- | 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)
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

164
NotCPP/Declarations.hs Normal file
View File

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

38
NotCPP/LookupValueName.hs Normal file
View File

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

114
NotCPP/OrphanEvasion.hs Normal file
View File

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

65
NotCPP/ScopeLookup.hs Normal file
View File

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

29
NotCPP/Utils.hs Normal file
View File

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

22
README.md
View File

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

198
Setup.hs Normal file → Executable file
View File

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

198
SetupCompat.hs Normal file
View File

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

37
Utils.hs Normal file
View File

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

4
doc/emacs.piki
View File

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

61
elisp/ghc-check.el
View File

@ -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.
'minibuffer displays errors/warnings in the minibuffer.
'other-buffer displays errors/warnings in the other buffer.
nil do not display errors/warnings.
'minibuffer display errors/warnings in the minibuffer.
'other-buffer display errors/warnings in a new buffer.
")
(defvar ghc-display-hole 'other-buffer
"*An action to display hole information for 'C-c C-j' and 'C-c C-h'
"*How to display hole information when using 'C-c C-j' and 'C-c C-h'
'minibuffer displays errors/warnings in the minibuffer.
'other-buffer displays errors/warnings in the other buffer"
'minibuffer display errors/warnings in the minibuffer.
'other-buffer display errors/warnings in the a new buffer"
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun ghc-check-syntax ()
(interactive)
(ghc-with-process (ghc-check-send)
'ghc-check-callback
(lambda () (setq mode-line-process " -:-"))))
;; Only check syntax of visible buffers
(when (and (buffer-file-name)
(file-exists-p (buffer-file-name))
(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 " -:-")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -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)
(forward-line (1- line))
(forward-char (1- coln))
(setq beg (point))
(forward-char (length hole))
(setq end (point)))
((string= ofile file)
(forward-line (1- line))
(while (eq (char-after) 32) (forward-char))
(setq beg (point))
(forward-line)
(setq end (1- (point))))
((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)))
(progn
(forward-line (1- line))
(forward-char (1- coln))
(setq beg (point))
(skip-chars-forward "^[:space:]" (line-end-position))
(setq end (point)))))
(t
(setq beg (point))
(forward-line)

2
elisp/ghc-comp.el
View File

@ -127,7 +127,7 @@ unloaded modules are loaded")
(interactive)
(if (ghc-should-scroll)
(ghc-scroll-completion-buffer)
(ghc-try-complete)))
(ghc-try-complete)))
(defun ghc-should-scroll ()
(let ((window (ghc-completion-window)))

4
elisp/ghc-doc.el
View File

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

14
elisp/ghc-func.el
View File

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

4
elisp/ghc-info.el
View File

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

2
elisp/ghc-pkg.el
View File

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

119
elisp/ghc-process.el
View File

@ -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,28 +34,30 @@
(ghc-run-ghc-mod '("root")))
(defun ghc-with-process (cmd callback &optional hook1 hook2)
(unless ghc-process-process-name
(setq ghc-process-process-name (ghc-get-project-root)))
(when (and ghc-process-process-name (not ghc-process-running))
(setq ghc-process-running t)
(if hook1 (funcall hook1))
(let* ((cbuf (current-buffer))
(name ghc-process-process-name)
(buf (get-buffer-create (concat " ghc-modi:" name)))
(file (buffer-file-name))
(cpro (get-process name)))
(ghc-with-current-buffer buf
(setq ghc-process-original-buffer cbuf)
(setq ghc-process-original-file file)
(setq ghc-process-callback callback)
(setq ghc-process-hook hook2)
(erase-buffer)
(let ((pro (ghc-get-process cpro name buf)))
(process-send-string pro cmd)
(when ghc-debug
(ghc-with-debug-buffer
(insert (format "%% %s" cmd))))
pro)))))
(let ((root (ghc-get-project-root)))
(unless ghc-process-process-name
(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-mod:" name)))
(file (buffer-file-name))
(cpro (get-process name)))
(ghc-with-current-buffer buf
(setq ghc-process-original-buffer cbuf)
(setq ghc-process-original-file file)
(setq ghc-process-callback callback)
(setq ghc-process-hook hook2)
(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))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -63,37 +71,74 @@
(t cpro)))
(defun ghc-start-process (name buf)
(let* ((opts (append '("-b" "\n" "-l") (ghc-make-ghc-options)))
(pro (apply 'start-file-process name buf ghc-interactive-command opts)))
(let* ((opts (append ghc-debug-options
'("-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)
(goto-char (point-max))
(insert string)
(ghc-with-current-buffer pbuf
(when ghc-debug
(ghc-with-debug-buffer
(insert string)))
(with-current-buffer (get-buffer-create tbufname)
(setq tbuf (current-buffer))
(goto-char (point-max))
(insert string)
(goto-char (point-min))
(let ((cont t) end out)
(while (and cont (not (eobp)))
(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)

11
elisp/ghc.el
View File

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

212
ghc-mod.cabal
View File

@ -1,73 +1,102 @@
Name: ghc-mod
Version: 5.2.1.2
Author: Kazu Yamamoto <kazu@iij.ad.jp>
Daniel Gröber <dxld@darkboxed.org>
Version: 5.3.0.0
Author: Kazu Yamamoto <kazu@iij.ad.jp>,
Daniel Gröber <dxld@darkboxed.org>,
Alejandro Serrano <trupill@gmail.com>
Maintainer: Kazu Yamamoto <kazu@iij.ad.jp>
License: BSD3
Maintainer: Daniel Gröber <dxld@darkboxed.org>
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
Haskell programming on editors including
Emacs, Vim, and Sublime.
The ghc-mod command is based on ghc-mod library
which is a wrapper of GHC API.
This package includes the ghc-mod command,
the ghc-mod library, and Emacs front-end
(for historical reasons).
For more information, please see its home page.
Description:
ghc-mod is a backend program to enrich Haskell programming in editors. It
strives to offer most of the features one has come to expect from modern IDEs
in any editor.
Category: Development
Cabal-Version: >= 1.10
Build-Type: Simple
Data-Dir: elisp
Data-Files: Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el
ghc-check.el ghc-process.el ghc-command.el ghc-info.el
ghc-ins-mod.el ghc-indent.el ghc-pkg.el ghc-rewrite.el
ghc-mod provides a library for other haskell programs to use as well as a
standalone program for easy editor integration. All of the fundamental
functionality of the frontend program can be accessed through the library
however many implementation details are hidden and if you want to
significantly extend ghc-mod you should submit these changes upstream instead
of implementing them on top of the library.
For more information, please see its home page.
Category: GHC, Development
Cabal-Version: >= 1.14
Build-Type: Custom
Data-Files: elisp/Makefile
elisp/*.el
Data-Files: LICENSE COPYING.BSD3 COPYING.AGPL3
Extra-Source-Files: ChangeLog
test/data/*.cabal
test/data/*.hs
test/data/cabal.sandbox.config.in
test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf
SetupCompat.hs
NotCPP/*.hs
test/data/annotations/*.hs
test/data/broken-cabal/*.cabal
test/data/broken-cabal/cabal.sandbox.config.in
test/data/broken-sandbox/*.cabal
test/data/broken-sandbox/cabal.sandbox.config
test/data/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/pattern-synonyms/*.hs
test/data/foreign-export/*.hs
test/data/ghc-mod-check/*.cabal
test/data/ghc-mod-check/*.hs
test/data/ghc-mod-check/Data/*.hs
test/data/subdir1/subdir2/dummy
test/data/.cabal-sandbox/packages/00-index.tar
test/data/ghc-mod-check/lib/Data/*.hs
test/data/hlint/*.hs
test/data/home-module-graph/cpp/*.hs
test/data/home-module-graph/cycle/*.hs
test/data/home-module-graph/errors/*.hs
test/data/home-module-graph/indirect/*.hs
test/data/home-module-graph/indirect-update/*.hs
test/data/import-cycle/*.hs
test/data/non-exported/*.hs
test/data/pattern-synonyms/*.cabal
test/data/pattern-synonyms/*.hs
test/data/quasi-quotes/*.hs
test/data/template-haskell/*.hs
test/data/target/*.hs
test/data/check-missing-warnings/*.hs
test/data/custom-cradle/custom-cradle.cabal
test/data/custom-cradle/ghc-mod.package-db-stack
test/data/custom-cradle/package-db-a/.gitkeep
test/data/custom-cradle/package-db-b/.gitkeep
test/data/custom-cradle/package-db-c/.gitkeep
test/data/cabal-preprocessors/*.cabal
test/data/cabal-preprocessors/*.hs
test/data/cabal-preprocessors/*.hsc
Library
Default-Language: Haskell2010
GHC-Options: -Wall
Default-Extensions: ConstraintKinds, FlexibleContexts
GHC-Options: -Wall -fno-warn-deprecations
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.Cabal18
Language.Haskell.GhcMod.Cabal21
Language.Haskell.GhcMod.CabalApi
Language.Haskell.GhcMod.CabalConfig
Language.Haskell.GhcMod.CabalHelper
Language.Haskell.GhcMod.Caching
Language.Haskell.GhcMod.Caching.Types
Language.Haskell.GhcMod.CaseSplit
Language.Haskell.GhcMod.Check
Language.Haskell.GhcMod.Convert
@ -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)
Build-Depends: Cabal >= 1.18
else
, fclabels
if impl(ghc < 7.8)
Build-Depends: convertible
, Cabal >= 1.10 && < 1.17
if impl(ghc <= 7.4.2)
if impl(ghc < 7.5)
-- Only used to constrain random to a version that still works with GHC 7.4
Build-Depends: random <= 1.0.1.1
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
, ghc-mod
, old-time
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
CabalApiSpec
CheckSpec
Other-Modules: Paths_ghc_mod
Dir
Spec
TestUtils
BrowseSpec
CheckSpec
FlagSpec
InfoSpec
LangSpec
@ -201,42 +235,14 @@ Test-Suite spec
ListSpec
MonadSpec
PathsAndFilesSpec
Spec
TestUtils
Build-Depends: base >= 4.0 && < 5
, containers
, 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
HomeModuleGraphSpec
Build-Depends: hspec >= 2.0.0
if impl(ghc == 7.4.*)
Build-Depends: executable-path
X-Build-Depends-Like: CLibName
Source-Repository head
Type: git

51
ghcmodHappyHaskellProgram-Dg.tex Normal file
View File

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

26
hcar-ghc-mod.tex
View File

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

15
scripts/bump.sh
View File

@ -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 commit -m "Bump version to $VERSION"
git add ChangeLog
git commit -m "ChangeLog"
git tag "v$VERSION"

36
scripts/compare-versions.sh Normal file
View File

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

479
src/GHCMod.hs
View File

@ -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.Environment (getArgs,getProgName)
import System.FilePath ((</>))
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.Unsafe (unsafePerformIO)
import System.FilePath (takeFileName)
import System.Exit (ExitCode, exitSuccess)
import System.IO (stdout, hSetEncoding, utf8, hFlush)
import System.Exit (exitSuccess)
import Text.PrettyPrint
import Prelude
import Misc
progVersion :: String -> String
progVersion pf =
"ghc-mod"++pf++" version " ++ showVersion version ++ " compiled by GHC "
++ cProjectVersion ++ "\n"
ghcModVersion :: String
ghcModVersion = progVersion ""
progVersion :: String
progVersion =
progName ++ " version " ++ showVersion version ++ " compiled by GHC "
++ cProjectVersion ++ "\n"
-- TODO: remove (ghc) version prefix!
progName :: String
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
"ghc-modi" -> ghcModiUsage
_ -> ghcModUsage
-- TODO: Generate the stuff below automatically
ghcModUsage :: String
ghcModUsage =
"Usage: ghc-mod [OPTIONS...] COMMAND [OPTIONS...] \n\
"Usage: ghc-mod [OPTIONS...] COMMAND [CMD_ARGS...] \n\
\*Global Options (OPTIONS)*\n\
\ Global options can be specified before and after the command and\n\
\ interspersed with command specific options\n\
\\n"
++ (unlines $ indent <$> optionUsage indent globalArgSpec) ++
"*Commands*\n\
\ - version | --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\
\ Try to find the project directory given FILE. For Cabal\n\
\ projects this is the directory containing the cabal file, for\n\
\ projects that use a cabal sandbox but have no cabal file this is the\n\
\ directory containing the sandbox and otherwise this is the directory\n\
\ containing FILE.\n\
\ - root\n\
\ Try to find the project directory. For Cabal projects this is the\n\
\ directory containing the cabal file, for projects that use a cabal\n\
\ sandbox but have no cabal file this is the directory containing the\n\
\ cabal.sandbox.config file and otherwise this is the current\n\
\ directory.\n\
\\n\
\ - doc MODULE\n\
\ Try finding the html documentation directory for the given MODULE.\n\
@ -197,57 +190,46 @@ ghcModUsage =
\ Print debugging information. Please include the output in any bug\n\
\ reports you submit.\n\
\\n\
\ - boot\n\
\ Internal command used by the emacs frontend.\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\
\ - debugComponent [MODULE_OR_FILE...]\n\
\ Debugging information related to cabal component resolution.\n\
\\n\
\ - help | --help\n\
\ Print this help message.\n"
\ - boot\n\
\ Internal command used by the emacs frontend.\n\
\\n\
\ - legacy-interactive\n\
\ ghc-modi compatibility mode.\n"
where
indent = (" "++)
cmdUsage :: String -> String -> String
cmdUsage cmd 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." $
NoArg $ \o -> o { ghcUserOptions = "-v" : ghcUserOptions o }
[ option "v" ["verbose"] "Increase or set log level. (0-7)" $
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"$
reqArg "SEP" $ \s o -> o { lineSeparator = LineSeparator s }
, option "b" ["boundary", "line-seperator"] "Output line separator"$
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" $
reqArg "OPT" $ \g o ->
, option "g" ["ghcOpt", "ghc-option"] "Option to be passed to GHC" $
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
(o,r,[] ) -> Right $ (foldr id defaultOptions o, r)
(_,_,errs) -> Left $ InvalidCommandLine $ Right $
"Parsing command line options failed: " ++ concat errs
= case O.getOpt' RequireOrder globalArgSpec argv of
(o,r,u,[]) -> case foldr (=<<) (Right defaultOptions) o of
Right o' -> Right (o', u ++ r)
Left c -> Right (defaultOptions, c)
(_,_,u,e) -> Left $ InvalidCommandLine $ Right $
"Parsing command line options failed: "
++ concat (e ++ map errUnrec u)
where
errUnrec :: String -> String
errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n"
parseCommandArgs :: [OptDescr (Options -> 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
def = InteractiveOptions False
handler :: IO a -> IO a
handler = flip catches $
[ Handler $ \(FatalError msg) -> exitError msg
, Handler $ \(InvalidCommandLine e) -> do
handler :: IOish m => GhcModT m a -> GhcModT m a
handler = flip gcatches $
[ GHandler $ \(FatalError msg) -> exitError msg
, GHandler $ \(InvalidCommandLine e) -> do
case e of
Left cmd ->
exitError $ (cmdUsage cmd ghcModUsage) ++ "\n"
++ progName ++ ": Invalid command line form."
Right msg -> exitError $ progName ++ ": " ++ msg
exitError $ "Usage for `"++cmd++"' command:\n\n"
++ (cmdUsage cmd usage) ++ "\n"
++ "ghc-mod: Invalid command line form."
Right msg -> exitError $ "ghc-mod: " ++ msg
, GHandler $ \(SomeException e) -> exitError $ "ghc-mod: " ++ show e
]
main :: IO ()
main = 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
Just s -> putStr s
Nothing -> throw e
Right res@(_,cmdArgs) ->
case globalCommands cmdArgs of
Just s -> putStr s
Nothing -> progMain res
Left e -> throw e
Right res -> progMain res
progMain :: (Options,[String]) -> IO ()
progMain (globalOptions,cmdArgs) = do
-- let (ghcArgs, modArgs) = second stripSeperator $ span (/="--") args
-- _realGhcArgs = filter (/="--ghc-mod") ghcArgs
-- (globalOptions,_cmdArgs) = parseGlobalArgs modArgs
-- stripSeperator ("--":rest) = rest
-- stripSeperator l = l
case progName of
"ghc-modi" -> do
legacyInteractive globalOptions =<< emptyNewUnGetLine
_
-- | "--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
progMain (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ handler $ do
case globalCommands cmdArgs of
Just s -> gmPutStr s
Nothing -> ghcCommands cmdArgs
where
hndle action = do
(e, _l) <- action
case e of
Right _ ->
return ()
Left ed ->
exitError' globalOptions $ renderStyle ghcModStyle (gmeDoc ed)
globalCommands :: [String] -> Maybe String
globalCommands (cmd:_)
| cmd == "help" = Just usage
| cmd == "version" = Just ghcModVersion
globalCommands _ = Nothing
-- ghc-modi
legacyInteractive :: Options -> UnGetLine -> IO ()
legacyInteractive opt ref = flip catches handlers $ do
(res,_) <- runGhcModT opt $ do
symdbreq <- liftIO $ newSymDbReq opt
world <- liftIO . getCurrentWorld =<< cradle
legacyInteractiveLoop symdbreq ref world
legacyInteractive :: IOish m => GhcModT m ()
legacyInteractive = do
opt <- options
prepareCabalHelper
tmpdir <- cradleTempDir <$> cradle
symdbreq <- liftIO $ newSymDbReq opt tmpdir
world <- getCurrentWorld
legacyInteractiveLoop symdbreq world
case res of
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 :: IOish m => String -> GhcModT m ()
bug msg = do
putStrLn $ notGood $ "BUG: " ++ msg
exitFailure
gmPutStrLn $ notGood $ "BUG: " ++ msg
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 ()
legacyInteractiveLoop symdbreq ref world = do
=> SymDbReq -> World -> GhcModT m ()
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
throw Restart
liftIO . prepareAutogen =<< cradle
dropSession
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
legacyInteractiveLoop symdbreq ref 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
gmPutStr res >> gmPutStrLn "OK" >> liftIO (hFlush stdout)
legacyInteractiveLoop symdbreq world
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 msg = hPutStrLn stderr msg >> exitFailure
exitError :: IOish m => String -> GhcModT m a
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,25 +497,43 @@ 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,
findSymbolCmd, lintCmd, rootInfoCmd, pkgDocCmd, dumpSymbolCmd, bootCmd
debugInfoCmd, componentInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd,
refineCmd, autoCmd, findSymbolCmd, lintCmd, rootInfoCmd, pkgDocCmd,
dumpSymbolCmd, bootCmd, legacyInteractiveCmd, nukeCachesCmd
:: IOish m => [String] -> GhcModT m String
modulesCmd = withParseCmd [] $ \[] -> modules
languagesCmd = withParseCmd [] $ \[] -> languages
flagsCmd = withParseCmd [] $ \[] -> flags
debugInfoCmd = withParseCmd [] $ \[] -> debugInfo
rootInfoCmd = withParseCmd [] $ \[] -> rootInfo
modulesCmd = withParseCmd' "modules" s $ \[] -> modules
where s = modulesArgSpec
languagesCmd = withParseCmd' "lang" [] $ \[] -> languages
flagsCmd = withParseCmd' "flag" [] $ \[] -> flags
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
findSymbolCmd = withParseCmd [] $ \[sym] -> findSymbol sym
pkgDocCmd = withParseCmd [] $ \[mdl] -> pkgDoc mdl
lintCmd = withParseCmd s $ \[file] -> lint file
dumpSymbolCmd = withParseCmd' "dump" [] $ \[tmpdir] -> dumpSymbol tmpdir
findSymbolCmd = withParseCmd' "find" [] $ \[sym] -> findSymbol sym
pkgDocCmd = withParseCmd' "doc" [] $ \[mdl] -> pkgDoc mdl
lintCmd = withParseCmd' "lint" s $ \[file] -> lint file
where s = hlintArgSpec
browseCmd = withParseCmd s $ \mdls -> concat <$> browse `mapM` mdls
browseCmd = withParseCmd s $ \mdls -> concat <$> browse `mapM` mdls
where s = browseArgSpec
checkSyntaxCmd = withParseCmd [] $ checkAction checkSyntax
expandTemplateCmd = withParseCmd [] $ checkAction expandTemplate
@ -565,10 +545,20 @@ autoCmd = withParseCmd [] $ locAction "auto" auto
refineCmd = withParseCmd [] $ locAction' "refine" refine
infoCmd = withParseCmd [] $ action
where action [file,_,expr] = info file expr
action [file,expr] = info file expr
where action [file,_,expr] = info file $ Expression expr
action [file,expr] = info file $ Expression expr
action _ = throw $ InvalidCommandLine (Left "info")
legacyInteractiveCmd = withParseCmd [] go
where
go [] =
legacyInteractive >> return ""
go ("help":[]) =
return usage
go ("version":[]) =
return ghcModiVersion
go _ = throw $ InvalidCommandLine (Left "legacy-interactive")
checkAction :: ([t] -> a) -> [t] -> a
checkAction _ [] = throw $ InvalidCommandLine (Right "No files given.")
checkAction action files = action files
@ -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' _ action [f,_,line,col,expr] = action f (read line) (read col) expr
locAction' _ action [f, line,col,expr] = action f (read line) (read col) expr
locAction' :: String -> (String -> Int -> Int -> Expression -> a) -> [String] -> a
locAction' _ action [f,_,line,col,expr] = action f (read line) (read col) (Expression expr)
locAction' _ action [f, line,col,expr] = action f (read line) (read col) (Expression expr)
locAction' cmd _ _ = throw $ InvalidCommandLine (Left cmd)
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

289
src/GHCModi.hs
View File

@ -1,262 +1,55 @@
{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
-- | WARNING
-- This program in the process of being deprecated, use `ghc-mod --interactive`
-- 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
-- This program is deprecated, use `ghc-mod legacy-interactive` instead.
module Main where
import Config (cProjectVersion)
import Control.Applicative ((<$>))
import Control.Exception (SomeException(..))
import qualified Control.Exception as E
import Control.Monad (when)
import CoreMonad (liftIO)
import Data.List (intercalate)
import Data.List.Split (splitOn)
import Data.Version (showVersion)
import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Internal
import Control.Applicative
import Control.Monad
import Control.Exception
import Data.Version
import Data.Maybe
import System.IO
import System.Exit
import System.Process
import System.FilePath
import System.Environment
import Paths_ghc_mod
import 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
----------------------------------------------------------------
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.
import Prelude
main :: IO ()
main = E.handle cmdHandler $
go =<< parseArgs argspec <$> getArgs
where
cmdHandler (CmdArg _) = putStr $ usageInfo usage argspec
go (_,"help":_) = putStr $ usageInfo usage argspec
go (_,"version":_) = putStr progVersion
go (opt,_) = emptyNewUnGetLine >>= run opt
main = do
hPutStrLn stderr $
"Warning: ghc-modi is deprecated please use 'ghc-mod legacy-interactive' instead"
run :: Options -> UnGetLine -> IO ()
run opt ref = flip E.catches handlers $ do
cradle0 <- findCradle
let rootdir = cradleRootDir cradle0
-- c = cradle0 { cradleCurrentDir = rootdir } TODO: ?????
setCurrentDirectory rootdir
prepareAutogen cradle0
-- Asynchronous db loading starts here.
symdbreq <- newSymDbReq opt
(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) ]
args <- getArgs
bindir <- getBinDir
let installedExe = bindir </> "ghc-mod"
mexe <- mplus <$> mightExist installedExe <*> pathExe
case mexe of
Nothing -> do
hPutStrLn stderr $
"ghc-modi: Could not find '"++installedExe++"', check your installation!"
exitWith $ ExitFailure 1
bug :: String -> IO ()
bug msg = do
putStrLn $ notGood $ "BUG: " ++ msg
exitFailure
Just exe -> do
(_, _, _, h) <-
createProcess $ proc exe $ ["legacy-interactive"] ++ args
exitWith =<< waitForProcess h
notGood :: String -> String
notGood msg = "NG " ++ escapeNewlines msg
pathExe :: IO (Maybe String)
pathExe = do
ev <- try $ words <$> readProcess "ghc-mod" ["--version"] ""
let mexe = case ev of
Left (SomeException _) -> Nothing
Right ["ghc-mod", "version", ver
, "compiled", "by", "GHC", _]
| showVersion version == ver -> do
Just "ghc-mod"
Right _ -> Nothing
escapeNewlines :: String -> String
escapeNewlines = replace "\n" "\\n" . replace "\\n" "\\\\n"
replace :: String -> String -> String -> String
replace needle replacement = intercalate replacement . splitOn needle
----------------------------------------------------------------
loop :: IOish m => 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 }
when (isNothing mexe) $
hPutStrLn stderr "ghc-modi: ghc-mod executable on PATH has different version, check your installation!"
return mexe

121
src/Misc.hs
View File

@ -1,75 +1,28 @@
{-# LANGUAGE DeriveDataTypeable, CPP #-}
module Misc (
GHCModiError(..)
, Restart(..)
, UnGetLine
, emptyNewUnGetLine
, ungetCommand
, getCommand
, SymDbReq
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 Data.Maybe (isJust)
import Data.Typeable (Typeable)
import System.Directory (doesDirectoryExist, getDirectoryContents)
import System.IO (openBinaryFile, IOMode(..))
import System.Process
import Prelude
import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Internal
----------------------------------------------------------------
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
import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
----------------------------------------------------------------
type SymDbReqAction = (Either GhcModError SymbolDb, GhcModLog)
data SymDbReq = SymDbReq (IORef (Async SymDbReqAction)) (IO SymDbReqAction)
newSymDbReq :: Options -> IO SymDbReq
newSymDbReq opt = do
let act = runGhcModT opt loadSymbolDb
newSymDbReq :: Options -> FilePath -> IO SymDbReq
newSymDbReq opt dir = do
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

27
src/Utils.hs
View File

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

9
test/BrowseSpec.hs
View File

@ -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
withDirectory_ "test/data" $ do
syms <- runID $ lines <$> browse "Baz"
syms `shouldContain` ["baz"]
it "can list symbols defined in a a local module" $ do
withDirectory_ "test/data/ghc-mod-check/lib" $ do
syms <- runD $ lines <$> browse "Data.Foo"
syms `shouldContain` ["foo"]
syms `shouldContain` ["fibonacci"]

77
test/CabalApiSpec.hs
View File

@ -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 = []})))]}]"

96
test/CabalHelperSpec.hs Normal file
View File

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

46
test/CheckSpec.hs
View File

@ -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
res <- runID $ checkSyntax ["Mutual1.hs"]
withDirectory_ "test/data/import-cycle" $ do
res <- runD $ checkSyntax ["Mutual1.hs"]
res `shouldSatisfy` ("Module imports form a cycle" `isInfixOf`)
it "works with modules using QuasiQuotes" $ do
withDirectory_ "test/data" $ do
res <- runID $ checkSyntax ["Baz.hs"]
res `shouldSatisfy` ("Baz.hs:5:1:Warning:" `isPrefixOf`)
withDirectory_ "test/data/quasi-quotes" $ do
res <- runD $ checkSyntax ["QuasiQuotes.hs"]
res `shouldSatisfy` ("QuasiQuotes.hs:6:1:Warning:" `isInfixOf`)
#if __GLASGOW_HASKELL__ >= 708
it "works with modules using PatternSynonyms" $ do
withDirectory_ "test/data/pattern-synonyms" $ do
res <- runID $ checkSyntax ["B.hs"]
res <- runD $ checkSyntax ["B.hs"]
res `shouldSatisfy` ("B.hs:6:9:Warning:" `isPrefixOf`)
#endif
it "works with foreign exports" $ do
withDirectory_ "test/data" $ do
res <- runID $ checkSyntax ["ForeignExport.hs"]
withDirectory_ "test/data/foreign-export" $ do
res <- runD $ checkSyntax ["ForeignExport.hs"]
res `shouldBe` ""
context "when no errors are found" $ do
it "doesn't output an empty line" $ do
withDirectory_ "test/data/ghc-mod-check/Data" $ do
res <- runID $ checkSyntax ["Foo.hs"]
withDirectory_ "test/data/ghc-mod-check/lib/Data" $ do
res <- runD $ checkSyntax ["Foo.hs"]
res `shouldBe` ""
#if __GLASGOW_HASKELL__ >= 708
-- See https://github.com/kazu-yamamoto/ghc-mod/issues/507
it "emits warnings generated in GHC's desugar stage" $ do
withDirectory_ "test/data/check-missing-warnings" $ do
res <- runD $ checkSyntax ["DesugarWarnings.hs"]
res `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"

80
test/CradleSpec.hs
View File

@ -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.FilePath ((</>), pathSeparator)
import System.Directory (canonicalizePath)
import System.FilePath (pathSeparator)
import Test.Hspec
import Dir
spec :: Spec
spec = do
describe "findCradle" $ do
it "returns the current directory" $ do
withDirectory_ "/" $ do
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]
clean_ :: IO Cradle -> IO Cradle
clean_ f = do
crdl <- f
cleanupCradle crdl
return crdl
relativeCradle :: FilePath -> Cradle -> Cradle
relativeCradle dir cradle = cradle {
cradleCurrentDir = toRelativeDir dir $ cradleCurrentDir cradle
, cradleRootDir = toRelativeDir dir $ cradleRootDir cradle
, cradleCabalFile = toRelativeDir dir <$> cradleCabalFile cradle
relativeCradle dir crdl = crdl {
cradleCurrentDir = toRelativeDir dir $ cradleCurrentDir crdl
, cradleRootDir = toRelativeDir dir $ cradleRootDir crdl
, cradleCabalFile = toRelativeDir dir <$> cradleCabalFile crdl
}
-- Work around GHC 7.2.2 where `canonicalizePath "/"` returns "/.".
@ -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")

10
test/Dir.hs
View File

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

5
test/FindSpec.hs
View File

@ -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
lookupSym "head" db `shouldContain` ["Data.List"]
db <- runD $ loadSymbolDb =<< (cradleTempDir `liftM` cradle)
lookupSym "head" db `shouldContain` [ModuleString "Data.List"]

29
test/GhcApiSpec.hs
View File

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

30
test/GhcPkgSpec.hs Normal file
View File

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

178
test/HomeModuleGraphSpec.hs Normal file
View File

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

46
test/InfoSpec.hs
View File

@ -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
res <- runD $ types "Data/Foo.hs" 9 5
res `shouldBe` "9 5 11 40 \"Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n"
let tdir = "test/data/ghc-mod-check"
res <- runD' tdir $ types "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
res <- runD $ types "Bar.hs" 5 1
res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]
let tdir = "test/data/template-haskell"
res <- runD' tdir $ types "Bar.hs" 5 1
res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]
it "works with a module that imports another module using TemplateHaskell" $ do
withDirectory_ "test/data" $ do
res <- runD $ types "Main.hs" 3 8
res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""]
let tdir = "test/data/template-haskell"
res <- runD' tdir $ types "ImportsTH.hs" 3 8
res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""]
describe "info" $ do
it "works for non-export functions" $ do
withDirectory_ "test/data" $ do
res <- runD $ info "Info.hs" "fib"
res `shouldSatisfy` ("fib :: Int -> Int" `isPrefixOf`)
it "works for non exported functions" $ do
let tdir = "test/data/non-exported"
res <- runD' tdir $ info "Fib.hs" $ Expression "fib"
res `shouldSatisfy` ("fib :: Int -> Int" `isPrefixOf`)
it "works with a module using TemplateHaskell" $ do
withDirectory_ "test/data" $ do
res <- runD $ info "Bar.hs" "foo"
res `shouldSatisfy` ("foo :: ExpQ" `isPrefixOf`)
let tdir = "test/data/template-haskell"
res <- runD' tdir $ info "Bar.hs" $ Expression "foo"
res `shouldSatisfy` ("foo :: ExpQ" `isPrefixOf`)
it "works with a module that imports another module using TemplateHaskell" $ do
withDirectory_ "test/data" $ do
res <- runD $ info "Main.hs" "bar"
res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`)
it "doesn't fail on unicode output" $ do
dir <- getDistDir
code <- rawSystem (dir </> "build/ghc-mod/ghc-mod") ["info", "test/data/Unicode.hs", "Unicode", "unicode"]
code `shouldSatisfy` (== ExitSuccess)
let tdir = "test/data/template-haskell"
res <- runD' tdir $ info "ImportsTH.hs" $ Expression "bar"
res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`)
getDistDir :: IO FilePath
getDistDir = takeDirectory . takeDirectory . takeDirectory <$> getExecutablePath

6
test/LintSpec.hs
View File

@ -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 `shouldBe` "test/data/hlint.hs:4:8: Error: Redundant do\NULFound:\NUL do putStrLn \"Hello, world!\"\NULWhy not:\NUL putStrLn \"Hello, world!\"\n"
res <- runD $ lint "test/data/hlint/hlint.hs"
res `shouldBe` "test/data/hlint/hlint.hs:4:8: Error: Redundant do\NULFound:\NUL do putStrLn \"Hello, world!\"\NULWhy not:\NUL putStrLn \"Hello, world!\"\n"
context "when no suggestions are given" $ do
it "doesn't output an empty line" $ do
res <- runD $ lint "test/data/ghc-mod-check/Data/Foo.hs"
res <- runD $ lint "test/data/ghc-mod-check/lib/Data/Foo.hs"
res `shouldBe` ""

25
test/Main.hs
View File

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

24
test/MonadSpec.hs
View File

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

35
test/PathsAndFilesSpec.hs
View File

@ -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/"
pkgDb `shouldBe` Just (cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d")
Just db <- getSandboxDb "test/data/cabal-project"
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"

46
test/TargetSpec.hs Normal file
View File

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

90
test/TestUtils.hs
View File

@ -1,26 +1,36 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module TestUtils (
run
, runD
, runD'
, runI
, runID
, runIsolatedGhcMod
, isolateCradle
, runE
, runNullLog
, 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
isolateCradle action =
local modifyEnv $ action
where
modifyEnv e = e { gmCradle = (gmCradle e) { cradlePkgDbStack = [GlobalDb] } }
import Exception
testLogLevel :: GmLogLevel
testLogLevel = GmDebug
extract :: Show e => IO (Either e a, w) -> IO a
extract action = do
@ -29,28 +39,46 @@ extract action = do
Right a -> return a
Left e -> error $ show e
runIsolatedGhcMod :: Options -> GhcModT IO a -> IO a
runIsolatedGhcMod opt action = do
extract $ runGhcModT opt $ isolateCradle action
withSpecCradle :: IOish m => FilePath -> (Cradle -> m a) -> m a
withSpecCradle cradledir f =
gbracket (liftIO $ findSpecCradle cradledir) (liftIO . cleanupCradle) f
-- | Run GhcMod in isolated cradle with default options
runID :: GhcModT IO a -> IO a
runID = runIsolatedGhcMod defaultOptions
withGhcModEnvSpec :: IOish m => FilePath -> Options -> (GhcModEnv -> m a) -> m a
withGhcModEnvSpec dir opt f = withSpecCradle dir $ withGhcModEnv' opt f
-- | Run GhcMod in isolated cradle
runI :: Options -> GhcModT IO a -> IO a
runI = runIsolatedGhcMod
runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog)
runGhcModTSpec opt action = do
dir <- getCurrentDirectory
runGhcModTSpec' dir opt action
runGhcModTSpec' :: IOish m
=> FilePath -> Options -> GhcModT m b -> m (Either GhcModError b, GhcModLog)
runGhcModTSpec' dir opt action = liftIO (canonicalizePath dir) >>= \dir' ->
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' = runGhcModT defaultOptions
runD' :: FilePath -> GhcModT IO a -> IO a
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

23
test/UtilsSpec.hs
View File

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

4
test/data/Unicode.hs
View File

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

6
test/data/annotations/With.hs Normal file
View File

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

1
test/data/bad.config
View File

@ -1 +0,0 @@
broken

3
test/data/cabal-flags/cabal-flags.cabal
View File

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

4
test/data/cabal-preprocessors/Main.hs Normal file
View File

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

3
test/data/cabal-preprocessors/Preprocessed.hsc Normal file
View File

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

14
test/data/cabal-preprocessors/cabal-preprocessors.cabal Normal file
View File

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

0
test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf → test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf
View File

Some files were not shown because too many files have changed in this diff Show More