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 cabal.sandbox.config
# Mac OS generates # Mac OS generates
# .DS_Store # .DS_Store
*.o
*.dyn_o
*.hi
*.dyn_hi
# Where do these files come from? They're not readable. # Where do these files come from? They're not readable.
# For instance, .#Help.page # For instance, .#Help.page
# .#* # .#*
cabal-dev cabal-dev
/TAGS
/tags

28
.travis.yml
View File

@ -4,11 +4,36 @@ ghc:
- 7.6 - 7.6
- 7.8 - 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: install:
- cabal update - 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 - happy --version
# - ls -lR ~/.ghc
# - ls -lR ~/.cabal
- cabal install -j --only-dependencies --enable-tests - cabal install -j --only-dependencies --enable-tests
- git clone --depth=1 https://github.com/DanielG/cabal-helper.git
- cabal install cabal-helper/
script: script:
- touch ChangeLog # Create ChangeLog if we're not on the release branch - 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 - 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 configure --enable-tests $WERROR
- cabal build - cabal build
- export ghc_mod_datadir=$PWD
- cabal test - cabal test
matrix: 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. ghc-mod was originally licensed under the BSD3 but the primary license has been
All rights reserved. changed to the AGPL3, files originally contributed under the BSD3 license remain
under this license and can generally be identified by the lack of a GPL header.
Redistribution and use in source and binary forms, with or without See the files COPYING.BSD3 and COPYING.AGPL3 in the source distribution for
modification, are permitted provided that the following conditions copies of the two licenses.
are met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in
the documentation and/or other materials provided with the
distribution.
* Neither the name of the copyright holders nor the names of its
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.

23
Language/Haskell/GhcMod.hs
View File

@ -3,15 +3,22 @@
module Language.Haskell.GhcMod ( module Language.Haskell.GhcMod (
-- * Cradle -- * Cradle
Cradle(..) Cradle(..)
, ProjectType(..)
, findCradle , findCradle
-- * Options -- * Options
, Options(..) , Options(..)
, LineSeparator(..) , LineSeparator(..)
, OutputStyle(..) , OutputStyle(..)
, defaultOptions , defaultOptions
-- * Logging
, GmLogLevel
, increaseLogLevel
, decreaseLogLevel
, gmSetLogLevel
, gmLog
-- * Types -- * Types
, ModuleString , ModuleString
, Expression , Expression(..)
, GhcPkgDb , GhcPkgDb
, Symbol , Symbol
, SymbolDb , SymbolDb
@ -22,12 +29,14 @@ module Language.Haskell.GhcMod (
-- * Monad utilities -- * Monad utilities
, runGhcModT , runGhcModT
, withOptions , withOptions
, dropSession
-- * 'GhcMod' utilities -- * 'GhcMod' utilities
, boot , boot
, browse , browse
, check , check
, checkSyntax , checkSyntax
, debugInfo , debugInfo
, componentInfo
, expandTemplate , expandTemplate
, info , info
, lint , lint
@ -47,6 +56,13 @@ module Language.Haskell.GhcMod (
-- * SymbolDb -- * SymbolDb
, loadSymbolDb , loadSymbolDb
, isOutdated , isOutdated
-- * Output
, gmPutStr
, gmErrStr
, gmPutStrLn
, gmErrStrLn
, gmUnsafePutStrLn
, gmUnsafeErrStrLn
) where ) where
import Language.Haskell.GhcMod.Boot import Language.Haskell.GhcMod.Boot
@ -61,7 +77,10 @@ import Language.Haskell.GhcMod.Flag
import Language.Haskell.GhcMod.Info import Language.Haskell.GhcMod.Info
import Language.Haskell.GhcMod.Lang import Language.Haskell.GhcMod.Lang
import Language.Haskell.GhcMod.Lint import Language.Haskell.GhcMod.Lint
import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Logging
import Language.Haskell.GhcMod.Modules import Language.Haskell.GhcMod.Modules
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.PkgDoc import Language.Haskell.GhcMod.PkgDoc
import Language.Haskell.GhcMod.Types 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 module Language.Haskell.GhcMod.Boot where
import Control.Applicative import Control.Applicative
import Prelude
import Language.Haskell.GhcMod.Browse import Language.Haskell.GhcMod.Browse
import Language.Haskell.GhcMod.Flag import Language.Haskell.GhcMod.Flag
import Language.Haskell.GhcMod.Lang import Language.Haskell.GhcMod.Lang
@ -9,8 +10,9 @@ import Language.Haskell.GhcMod.Modules
-- | Printing necessary information for front-end booting. -- | Printing necessary information for front-end booting.
boot :: IOish m => GhcModT m String boot :: IOish m => GhcModT m String
boot = concat <$> sequence [modules, languages, flags, boot = concat <$> sequence ms
concat <$> mapM browse preBrowsedModules] where
ms = [modules, languages, flags, concat <$> mapM browse preBrowsedModules]
preBrowsedModules :: [String] preBrowsedModules :: [String]
preBrowsedModules = [ preBrowsedModules = [

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

@ -2,54 +2,57 @@ module Language.Haskell.GhcMod.Browse (
browse browse
) where ) where
import Control.Applicative ((<$>)) import Control.Applicative
import Control.Exception (SomeException(..)) import Control.Exception (SomeException(..))
import Data.Char (isAlpha) import Data.Char
import Data.List (sort) import Data.List
import Data.Maybe (catMaybes) import Data.Maybe
import Exception (ghandle) import FastString
import FastString (mkFastString) import GHC
import GHC (GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon)
import qualified GHC as G import qualified GHC as G
import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Doc (showPage, styleUnqualified) import Language.Haskell.GhcMod.Doc (showPage, styleUnqualified)
import Language.Haskell.GhcMod.Gap import Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Monad (GhcModT, options) import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Target (setTargetFiles)
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Name (getOccString) import Name (getOccString)
import Outputable (ppr, Outputable) import Outputable
import TyCon (isAlgTyCon) import TyCon (isAlgTyCon)
import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy) import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy)
import Exception (ExceptionMonad, ghandle)
import Prelude
---------------------------------------------------------------- ----------------------------------------------------------------
-- | Getting functions, classes, etc from a module. -- | Getting functions, classes, etc from a module.
-- If 'detailed' is 'True', their types are also obtained. -- If 'detailed' is 'True', their types are also obtained.
-- If 'operators' is 'True', operators are also returned. -- If 'operators' is 'True', operators are also returned.
browse :: IOish m browse :: forall m. IOish m
=> ModuleString -- ^ A module name. (e.g. \"Data.List\") => String -- ^ A module name. (e.g. \"Data.List\", "base:Prelude")
-> GhcModT m String -> GhcModT m String
browse pkgmdl = convert' . sort =<< (listExports =<< getModule) browse pkgmdl = do
convert' . sort =<< go
where 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 mdlname = G.mkModuleName mdl
mpkgid = mkFastString <$> mpkg 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" -- >>> splitPkgMdl "base:Prelude"
@ -57,9 +60,10 @@ browse pkgmdl = convert' . sort =<< (listExports =<< getModule)
-- >>> splitPkgMdl "Prelude" -- >>> splitPkgMdl "Prelude"
-- (Nothing,"Prelude") -- (Nothing,"Prelude")
splitPkgMdl :: String -> (Maybe String,String) splitPkgMdl :: String -> (Maybe String,String)
splitPkgMdl pkgmdl = case break (==':') pkgmdl of splitPkgMdl pkgmdl =
(mdl,"") -> (Nothing,mdl) case break (==':') pkgmdl of
(pkg,_:mdl) -> (Just pkg,mdl) (mdl, "") -> (Nothing, mdl)
(pkg, _:mdl) -> (Just pkg, mdl)
-- Haskell 2010: -- Haskell 2010:
-- small -> ascSmall | uniSmall | _ -- small -> ascSmall | uniSmall | _
@ -71,22 +75,23 @@ isNotOp :: String -> Bool
isNotOp (h:_) = isAlpha h || (h == '_') isNotOp (h:_) = isAlpha h || (h == '_')
isNotOp _ = error "isNotOp" isNotOp _ = error "isNotOp"
processExports :: IOish m => ModuleInfo -> GhcModT m [String] processExports :: (G.GhcMonad m, MonadIO m, ExceptionMonad m)
processExports minfo = do => Options -> ModuleInfo -> m [String]
opt <- options processExports opt minfo = do
let let
removeOps removeOps
| operators opt = id | operators opt = id
| otherwise = filter (isNotOp . getOccString) | otherwise = filter (isNotOp . getOccString)
mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo 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 showExport opt minfo e = do
mtype' <- mtype mtype' <- mtype
return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype'] return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype']
where where
mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` qualified opt mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` qualified opt
mtype :: IOish m => GhcModT m (Maybe String) mtype :: m (Maybe String)
mtype mtype
| detailed opt = do | detailed opt = do
tyInfo <- G.modInfoLookupName minfo e tyInfo <- G.modInfoLookupName minfo e
@ -101,8 +106,9 @@ showExport opt minfo e = do
| null nm = error "formatOp" | null nm = error "formatOp"
| isNotOp nm = nm | isNotOp nm = nm
| otherwise = "(" ++ nm ++ ")" | otherwise = "(" ++ nm ++ ")"
inOtherModule :: IOish m => Name -> GhcModT m (Maybe TyThing) inOtherModule :: Name -> m (Maybe TyThing)
inOtherModule nm = G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm inOtherModule nm = do
G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm
justIf :: a -> Bool -> Maybe a justIf :: a -> Bool -> Maybe a
justIf x True = Just x justIf x True = Just x
justIf _ False = Nothing justIf _ False = Nothing
@ -127,7 +133,7 @@ tyType typ
&& not (G.isClassTyCon typ) = Just "data" && not (G.isClassTyCon typ) = Just "data"
| G.isNewTyCon typ = Just "newtype" | G.isNewTyCon typ = Just "newtype"
| G.isClassTyCon typ = Just "class" | G.isClassTyCon typ = Just "class"
| G.isSynTyCon typ = Just "type" | Gap.isSynTyCon typ = Just "type"
| otherwise = Nothing | otherwise = Nothing
removeForAlls :: Type -> Type 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 Data.Maybe (isJust)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.IO as T (readFile) import qualified Data.Text.IO as T (readFile)
import System.FilePath
import qualified DataCon as Ty import qualified DataCon as Ty
import Exception (ghandle, SomeException(..))
import GHC (GhcMonad, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) import GHC (GhcMonad, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
import qualified GHC as G 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 Outputable (PprStyle)
import qualified TyCon as Ty import qualified TyCon as Ty
import qualified Type 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 -- CASE SPLITTING
@ -38,23 +45,29 @@ splits :: IOish m
-> Int -- ^ Line number. -> Int -- ^ Line number.
-> Int -- ^ Column number. -> Int -- ^ Column number.
-> GhcModT m String -> GhcModT m String
splits file lineNo colNo = ghandle handler body splits file lineNo colNo =
where ghandle handler $ runGmlT' [Left file] deferErrors $ do
body = inModuleContext file $ \dflag style -> do opt <- options
opt <- options crdl <- cradle
modSum <- Gap.fileModSummary file style <- getStyle
whenFound' opt (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of dflag <- G.getSessionDynFlags
(SplitInfo varName bndLoc (varLoc,varT) _matches) -> do modSum <- Gap.fileModSummary (cradleCurrentDir crdl </> file)
let varName' = showName dflag style varName -- Convert name to string whenFound' opt (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of
text <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $ (SplitInfo varName bndLoc (varLoc,varT) _matches) -> do
getTyCons dflag style varName varT) let varName' = showName dflag style varName -- Convert name to string
return (fourInts bndLoc, text) t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
(TySplitInfo varName bndLoc (varLoc,varT)) -> do getTyCons dflag style varName varT)
let varName' = showName dflag style varName -- Convert name to string return (fourInts bndLoc, t)
text <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $ (TySplitInfo varName bndLoc (varLoc,varT)) -> do
getTyCons dflag style varName varT) let varName' = showName dflag style varName -- Convert name to string
return (fourInts bndLoc, text) t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
handler (SomeException _) = emptyResult =<< options 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 -- 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 varT <- Gap.getType tcm varPat' -- Finally we get the type of the var
case varT of case varT of
Just varT' -> 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 let (L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match
#endif
in return $ Just (SplitInfo (getPatternVarName varPat') matchL varT' (map G.getLoc rhsLs) ) in return $ Just (SplitInfo (getPatternVarName varPat') matchL varT' (map G.getLoc rhsLs) )
_ -> return Nothing _ -> 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 -- 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 genCaseSplitTextFile file info = liftIO $ do
text <- T.readFile file t <- T.readFile file
return $ getCaseSplitText (T.lines text) info return $ getCaseSplitText (T.lines t) info
getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String
getCaseSplitText text (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS getCaseSplitText t (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS
, sVarSpan = sVS, sTycons = sT }) = , sVarSpan = sVS, sTycons = sT }) =
let bindingText = getBindingText text sBS let bindingText = getBindingText t sBS
difference = srcSpanDifference sBS sVS difference = srcSpanDifference sBS sVS
replaced = map (replaceVarWithTyCon bindingText difference sVN) sT replaced = map (replaceVarWithTyCon bindingText difference sVN) sT
-- The newly generated bindings need to be indented to align with the -- 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') in T.unpack $ T.intercalate (T.pack "\n") (concat replaced')
getBindingText :: [T.Text] -> SrcSpan -> [T.Text] getBindingText :: [T.Text] -> SrcSpan -> [T.Text]
getBindingText text srcSpan = getBindingText t srcSpan =
let Just (sl,sc,el,ec) = Gap.getSrcSpan 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 in if sl == el
then -- only one line then -- only one line
[T.drop (sc - 1) $ T.take ec $ head lines_] [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 in (vsl - bsl, vsc - bsc, vel - bsl, vec - bsc) -- assume variable in one line
replaceVarWithTyCon :: [T.Text] -> (Int,Int,Int,Int) -> String -> String -> [T.Text] replaceVarWithTyCon :: [T.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 let tycon' = if ' ' `elem` tycon || ':' `elem` tycon then "(" ++ tycon ++ ")" else tycon
lengthDiff = length tycon' - length varname lengthDiff = length tycon' - length varname
tycon'' = T.pack $ if lengthDiff < 0 then tycon' ++ replicate (-lengthDiff) ' ' else tycon' 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 else if n == vsl
then T.take vsc line `T.append` tycon'' `T.append` T.drop vec line then T.take vsc line `T.append` tycon'' `T.append` T.drop vec line
else T.replicate spacesToAdd (T.pack " ") `T.append` line) else T.replicate spacesToAdd (T.pack " ") `T.append` line)
[0 ..] text [0 ..] t
indentBindingTo :: SrcSpan -> [T.Text] -> [T.Text] indentBindingTo :: SrcSpan -> [T.Text] -> [T.Text]
indentBindingTo bndLoc binds = indentBindingTo bndLoc binds =

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

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

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 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 Language.Haskell.GhcMod.Types
import Control.Applicative ((<$>)) import Control.Applicative
import Prelude
type Builder = String -> String type Builder = String -> String
@ -23,11 +24,11 @@ inter :: Char -> [Builder] -> Builder
inter _ [] = id inter _ [] = id
inter c bs = foldr1 (\x y -> x . (c:) . y) bs 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' x = flip convert x <$> options
convert :: ToString a => Options -> a -> String 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 convert opt@Options { outputStyle = PlainStyle } x
| str == "\n" = "" | str == "\n" = ""
| otherwise = str | otherwise = str
@ -35,8 +36,8 @@ convert opt@Options { outputStyle = PlainStyle } x
str = toPlain opt x "\n" str = toPlain opt x "\n"
class ToString a where class ToString a where
toLisp :: Options -> a -> Builder toLisp :: Options -> a -> Builder
toPlain :: Options -> a -> Builder toPlain :: Options -> a -> Builder
lineSep :: Options -> String lineSep :: Options -> String
lineSep opt = interpret lsep lineSep opt = interpret lsep
@ -51,8 +52,8 @@ lineSep opt = interpret lsep
-- >>> toPlain defaultOptions "foo" "" -- >>> toPlain defaultOptions "foo" ""
-- "foo" -- "foo"
instance ToString String where instance ToString String where
toLisp opt = quote opt toLisp opt = quote opt
toPlain opt = replace '\n' (lineSep opt) toPlain opt = replace '\n' (lineSep opt)
-- | -- |
-- --
@ -61,8 +62,12 @@ instance ToString String where
-- >>> toPlain defaultOptions ["foo", "bar", "baz"] "" -- >>> toPlain defaultOptions ["foo", "bar", "baz"] ""
-- "foo\nbar\nbaz" -- "foo\nbar\nbaz"
instance ToString [String] where instance ToString [String] where
toLisp opt = toSexp1 opt toLisp opt = toSexp1 opt
toPlain opt = inter '\n' . map (toPlain 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 "" -- >>> toPlain defaultOptions inp ""
-- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\"" -- "1 2 3 4 \"foo\"\n5 6 7 8 \"bar\""
instance ToString [((Int,Int,Int,Int),String)] where instance ToString [((Int,Int,Int,Int),String)] where
toLisp opt = toSexp2 . map toS toLisp opt = toSexp2 . map toS
where where
toS x = ('(' :) . tupToString opt x . (')' :) toS x = ('(' :) . tupToString opt x . (')' :)
toPlain opt = inter '\n' . map (tupToString opt) toPlain opt = inter '\n' . map (tupToString opt)
instance ToString ((Int,Int,Int,Int),String) where instance ToString ((Int,Int,Int,Int),String) where
toLisp opt x = ('(' :) . tupToString opt x . (')' :) toLisp opt x = ('(' :) . tupToString opt x . (')' :)
toPlain opt x = tupToString opt x toPlain opt x = tupToString opt x
instance ToString ((Int,Int,Int,Int),[String]) where instance ToString ((Int,Int,Int,Int),[String]) where
toLisp opt (x,s) = ('(' :) . fourIntsToString opt x . toLisp opt (x,s) = ('(' :) . fourIntsToString opt x .
(' ' :) . toLisp opt s . (')' :) (' ' :) . toLisp opt s . (')' :)
toPlain opt (x,s) = fourIntsToString opt x . ('\n' :) . toPlain opt s toPlain opt (x,s) = fourIntsToString opt x . ('\n' :) . toPlain opt s
instance ToString (String, (Int,Int,Int,Int),[String]) where instance ToString (String, (Int,Int,Int,Int),[String]) where
toLisp opt (s,x,y) = toSexp2 [toLisp opt s, ('(' :) . fourIntsToString opt x . (')' :), toLisp 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] toPlain opt (s,x,y) = inter '\n' [toPlain opt s, fourIntsToString opt x, toPlain opt y]
toSexp1 :: Options -> [String] -> Builder toSexp1 :: Options -> [String] -> Builder
toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :) 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 ( module Language.Haskell.GhcMod.Cradle (
findCradle findCradle
, findCradle' , findCradle'
, findCradleWithoutSandbox , findSpecCradle
, cleanupCradle , cleanupCradle
) where ) where
import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.Utils
import Control.Exception.IOChoice ((||>)) import Control.Applicative
import System.Directory (getCurrentDirectory, removeDirectoryRecursive) import Control.Monad
import System.FilePath (takeDirectory) import Control.Monad.Trans.Maybe
import Data.Maybe
import System.Directory
import System.FilePath
import Prelude
---------------------------------------------------------------- ----------------------------------------------------------------
@ -25,51 +28,62 @@ findCradle :: IO Cradle
findCradle = findCradle' =<< getCurrentDirectory findCradle = findCradle' =<< getCurrentDirectory
findCradle' :: FilePath -> IO Cradle 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 :: Cradle -> IO ()
cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl 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 cabalCradle wdir = do
Just cabalFile <- findCabalFile wdir cabalFile <- MaybeT $ findCabalFile wdir
let cabalDir = takeDirectory cabalFile let cabalDir = takeDirectory cabalFile
pkgDbStack <- getPackageDbStack cabalDir
tmpDir <- newTempDir cabalDir
return Cradle { return Cradle {
cradleCurrentDir = wdir cradleProjectType = CabalProject
, cradleCurrentDir = wdir
, cradleRootDir = cabalDir , cradleRootDir = cabalDir
, cradleTempDir = tmpDir , cradleTempDir = error "tmpDir"
, cradleCabalFile = Just cabalFile , cradleCabalFile = Just cabalFile
, cradlePkgDbStack = pkgDbStack
} }
sandboxCradle :: FilePath -> IO Cradle sandboxCradle :: FilePath -> MaybeT IO Cradle
sandboxCradle wdir = do sandboxCradle wdir = do
Just sbDir <- getSandboxDb wdir sbDir <- MaybeT $ findCabalSandboxDir wdir
pkgDbStack <- getPackageDbStack sbDir
tmpDir <- newTempDir sbDir
return Cradle { return Cradle {
cradleCurrentDir = wdir cradleProjectType = SandboxProject
, cradleCurrentDir = wdir
, cradleRootDir = sbDir , cradleRootDir = sbDir
, cradleTempDir = tmpDir , cradleTempDir = error "tmpDir"
, cradleCabalFile = Nothing , cradleCabalFile = Nothing
, cradlePkgDbStack = pkgDbStack
} }
plainCradle :: FilePath -> IO Cradle plainCradle :: FilePath -> MaybeT IO Cradle
plainCradle wdir = do plainCradle wdir = do
tmpDir <- newTempDir wdir return $ Cradle {
return Cradle { cradleProjectType = PlainProject
cradleCurrentDir = wdir , cradleCurrentDir = wdir
, cradleRootDir = wdir , cradleRootDir = wdir
, cradleTempDir = tmpDir , cradleTempDir = error "tmpDir"
, cradleCabalFile = Nothing , 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 Control.Arrow (first)
import Data.List (intercalate) import Control.Applicative
import Data.Maybe (isJust, fromJust) import Control.Monad
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Char
import Data.List.Split
import Text.PrettyPrint
import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Internal import Language.Haskell.GhcMod.Internal
import Language.Haskell.GhcMod.Target
import Language.Haskell.GhcMod.Pretty
import Language.Haskell.GhcMod.Utils
---------------------------------------------------------------- ----------------------------------------------------------------
-- | Obtaining debug information. -- | Obtaining debug information.
debugInfo :: IOish m => GhcModT m String debugInfo :: IOish m => GhcModT m String
debugInfo = cradle >>= \c -> convert' =<< do debugInfo = do
CompilerOptions gopts incDir pkgs <- Options {..} <- options
if isJust $ cradleCabalFile c then Cradle {..} <- cradle
fromCabalFile c ||> simpleCompilerOption
else
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
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. -- | Obtaining root information.

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

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

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

@ -2,7 +2,7 @@
module Language.Haskell.GhcMod.DynFlags where module Language.Haskell.GhcMod.DynFlags where
import Control.Applicative ((<$>)) import Control.Applicative
import Control.Monad (void) import Control.Monad (void)
import GHC (DynFlags(..), GhcMode(..), GhcLink(..), HscTarget(..)) import GHC (DynFlags(..), GhcMode(..), GhcLink(..), HscTarget(..))
import qualified GHC as G import qualified GHC as G
@ -11,8 +11,7 @@ import GhcMonad
import qualified Language.Haskell.GhcMod.Gap as Gap import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
import Prelude
data Build = CabalPkg | SingleFile deriving Eq
setEmptyLogger :: DynFlags -> DynFlags setEmptyLogger :: DynFlags -> DynFlags
setEmptyLogger df = Gap.setLogAction df $ \_ _ _ _ _ -> return () setEmptyLogger df = Gap.setLogAction df $ \_ _ _ _ _ -> return ()
@ -41,37 +40,15 @@ setModeIntelligent df = df {
, optLevel = 0 , 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 -- | Parse command line ghc options and add them to the 'DynFlags' passed
addCmdOpts :: GhcMonad m => [GHCOption] -> DynFlags -> m DynFlags addCmdOpts :: GhcMonad m => [GHCOption] -> DynFlags -> m DynFlags
addCmdOpts cmdOpts df = addCmdOpts cmdOpts df =
tfst <$> G.parseDynamicFlags df (map G.noLoc cmdOpts) fst3 <$> G.parseDynamicFlags df (map G.noLoc cmdOpts)
where 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 withDynFlags :: GhcMonad m
=> (DynFlags -> DynFlags) => (DynFlags -> DynFlags)
-> m a -> m a
@ -119,3 +96,7 @@ setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing }
#else #else
setNoMaxRelevantBindings = id setNoMaxRelevantBindings = id
#endif #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 ( module Language.Haskell.GhcMod.Error (
GhcModError(..) GhcModError(..)
, GMConfigStateFileError(..)
, GmError
, gmeDoc , gmeDoc
, ghcExceptionDoc
, liftMaybe
, overrideError
, modifyError , modifyError
, modifyError' , modifyError'
, modifyGmError
, tryFix , tryFix
, GHandler(..)
, gcatches
, module Control.Monad.Error , module Control.Monad.Error
, module Exception , module Control.Exception
) where ) 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.List
import Data.Typeable import Data.Version
import Exception import System.Process (showCommandForUser)
import Text.PrettyPrint import Text.PrettyPrint
import Text.Printf
data GhcModError = GMENoMsg import Exception
-- ^ Unknown error import Panic
| GMEString String import Config (cProjectVersion, cHostPlatformString)
-- ^ Some Error with a message. These are produced mostly by import Paths_ghc_mod (version)
-- 'fail' calls on GhcModT.
| GMEIOException IOException
-- ^ IOExceptions captured by GhcModT's MonadIO instance
| GMECabalConfigure GhcModError
-- ^ Configuring a cabal project failed.
| GMECabalFlags GhcModError
-- ^ Retrieval of the cabal configuration flags failed.
| GMEProcess [String] GhcModError
-- ^ Launching an operating system process failed. The first
-- field is the command.
| GMENoCabalFile
-- ^ No cabal file found.
| GMETooManyCabalFiles [FilePath]
-- ^ Too many cabal files found.
deriving (Eq,Show,Typeable)
instance Exception GhcModError import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Pretty
instance Error GhcModError where type GmError m = MonadError GhcModError m
noMsg = GMENoMsg
strMsg = GMEString gmCsfeDoc :: GMConfigStateFileError -> Doc
gmCsfeDoc GMConfigStateFileNoHeader = text $
"Saved package config file header is missing. "
++ "Try re-running the 'configure' command."
gmCsfeDoc GMConfigStateFileBadHeader = text $
"Saved package config file header is corrupt. "
++ "Try re-running the 'configure' command."
gmCsfeDoc GMConfigStateFileNoParse = text $
"Saved package config file body is corrupt. "
++ "Try re-running the 'configure' command."
gmCsfeDoc GMConfigStateFileMissing = text $
"Run the 'configure' command first."
-- gmCsfeDoc (ConfigStateFileBadVersion oldCabal oldCompiler _) = text $
-- "You need to re-run the 'configure' command. "
-- ++ "The version of Cabal being used has changed (was "
-- ++ display oldCabal ++ ", now "
-- ++ display currentCabalId ++ ")."
-- ++ badCompiler
-- where
-- badCompiler
-- | oldCompiler == currentCompilerId = ""
-- | otherwise =
-- " Additionally the compiler is different (was "
-- ++ display oldCompiler ++ ", now "
-- ++ display currentCompilerId
-- ++ ") which is probably the cause of the problem."
gmeDoc :: GhcModError -> Doc gmeDoc :: GhcModError -> Doc
gmeDoc e = case e of gmeDoc e = case e of
@ -47,20 +90,83 @@ gmeDoc e = case e of
text "Unknown error" text "Unknown error"
GMEString msg -> GMEString msg ->
text msg text msg
GMEIOException ioe ->
text $ show ioe
GMECabalConfigure msg -> GMECabalConfigure msg ->
text "cabal configure failed: " <> gmeDoc msg text "Configuring cabal project failed: " <> gmeDoc msg
GMECabalFlags msg -> GMECabalFlags msg ->
text "retrieval of the cabal configuration flags failed: " <> gmeDoc msg text "Retrieval of the cabal configuration flags failed: " <> gmeDoc msg
GMEProcess cmd msg -> GMECabalComponent cn ->
text ("launching operating system process `"++unwords cmd++"` failed: ") text "Cabal component " <> quotes (gmComponentNameDoc cn)
<> gmeDoc msg <> text " could not be found."
GMECabalCompAssignment ctx ->
text "Could not find a consistent component assignment for modules:" $$
(nest 4 $ foldr ($+$) empty $ map ctxDoc ctx) $$
text "" $$
(if all (Set.null . snd) ctx
then noComponentSuggestions
else empty) $$
text "- To find out which components ghc-mod knows about try:" $$
nest 4 (backticks $ text "ghc-mod debug")
where
noComponentSuggestions =
text "- Are some of these modules part of a test and or benchmark?\
\ Try enabling them:" $$
nest 4 (backticks $ text "cabal configure --enable-tests [--enable-benchmarks]")
backticks d = char '`' <> d <> char '`'
ctxDoc = moduleDoc *** compsDoc
>>> first (<> colon) >>> uncurry (flip hang 4)
moduleDoc (Left fn) =
text "File " <> quotes (text fn)
moduleDoc (Right mdl) =
text "Module " <> quotes (text $ moduleNameString mdl)
compsDoc sc | Set.null sc = text "has no known components"
compsDoc sc = fsep $ punctuate comma $
map gmComponentNameDoc $ Set.toList sc
GMEProcess cmd args emsg -> let c = showCommandForUser cmd args in
case emsg of
Right err ->
text (printf "Launching system command `%s` failed: " c)
<> gmeDoc err
Left (_out, _err, rv) -> text $
printf "Launching system command `%s` failed (exited with %d)" c rv
GMENoCabalFile -> GMENoCabalFile ->
text "No cabal file found." text "No cabal file found."
GMETooManyCabalFiles cfs -> GMETooManyCabalFiles cfs ->
text $ "Multiple cabal files found. Possible cabal files: \"" text $ "Multiple cabal files found. Possible cabal files: \""
++ intercalate "\", \"" cfs ++"\"." ++ 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 :: MonadError e m => (e -> e) -> m a -> m a
modifyError f action = action `catchError` \e -> throwError $ f e 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' :: MonadError e m => m a -> (e -> e) -> m a
modifyError' = flip modifyError 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 :: MonadError e m => m a -> (e -> m ()) -> m a
tryFix action fix = do tryFix action f = do
action `catchError` \e -> fix e >> action action `catchError` \e -> f e >> action
data GHandler m a = forall e . Exception e => GHandler (e -> m a)
gcatches :: (MonadIO m, ExceptionMonad m) => m a -> [GHandler m a] -> m a
gcatches io handlers = io `gcatch` gcatchesHandler handlers
gcatchesHandler :: (MonadIO m, ExceptionMonad m)
=> [GHandler m a] -> SomeException -> m a
gcatchesHandler handlers e = foldr tryHandler (liftIO $ throw e) handlers
where tryHandler (GHandler handler) res
= case fromException e of
Just e' -> handler e'
Nothing -> res

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

@ -11,7 +11,8 @@ import Data.Char (isSymbol)
import Data.Function (on) import Data.Function (on)
import Data.List (find, nub, sortBy) import Data.List (find, nub, sortBy)
import qualified Data.Map as M 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 Exception (ghandle, SomeException(..))
import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags,
SrcSpan, Type, GenLocated(L)) SrcSpan, Type, GenLocated(L))
@ -19,8 +20,12 @@ import qualified GHC as G
import qualified Name as G import qualified Name as G
import qualified Language.Haskell.GhcMod.Gap as Gap import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.DynFlags
import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.SrcUtils import Language.Haskell.GhcMod.SrcUtils
import Language.Haskell.GhcMod.Logging (gmLog)
import Language.Haskell.GhcMod.Pretty (showDoc)
import Language.Haskell.GhcMod.Doc
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Outputable (PprStyle) import Outputable (PprStyle)
import qualified Type as Ty import qualified Type as Ty
@ -31,6 +36,10 @@ import qualified HsPat as Ty
import qualified Language.Haskell.Exts.Annotated as HE import qualified Language.Haskell.Exts.Annotated as HE
import Djinn.GHC import Djinn.GHC
#if __GLASGOW_HASKELL__ >= 710
import GHC (unLoc)
#endif
---------------------------------------------------------------- ----------------------------------------------------------------
-- INTIAL CODE FROM FUNCTION OR INSTANCE SIGNATURE -- INTIAL CODE FROM FUNCTION OR INSTANCE SIGNATURE
---------------------------------------------------------------- ----------------------------------------------------------------
@ -62,22 +71,27 @@ sig :: IOish m
-> Int -- ^ Line number. -> Int -- ^ Line number.
-> Int -- ^ Column number. -> Int -- ^ Column number.
-> GhcModT m String -> GhcModT m String
sig file lineNo colNo = ghandle handler body sig file lineNo colNo =
where runGmlT' [Left file] deferErrors $ ghandle fallback $ do
body = inModuleContext file $ \dflag style -> do opt <- options
opt <- options style <- getStyle
modSum <- Gap.fileModSummary file dflag <- G.getSessionDynFlags
whenFound opt (getSignature modSum lineNo colNo) $ \s -> case s of modSum <- Gap.fileModSummary file
whenFound opt (getSignature modSum lineNo colNo) $ \s ->
case s of
Signature loc names ty -> 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 -> InstanceDecl loc cls ->
("instance", fourInts loc, map (\x -> initialBody dflag style (G.idType x) x) let body x = initialBody dflag style (G.idType x) x
(Ty.classMethods cls)) in ("instance", fourInts loc, body `map` Ty.classMethods cls)
TyFamDecl loc name flavour vars -> TyFamDecl loc name flavour vars ->
let (rTy, initial) = initialTyFamString flavour let (rTy, initial) = initialTyFamString flavour
in (rTy, fourInts loc, [initial ++ initialFamBody dflag style name vars]) body = initialFamBody dflag style name vars
in (rTy, fourInts loc, [initial ++ body])
handler (SomeException _) = do where
fallback (SomeException _) = do
opt <- options opt <- options
-- Code cannot be parsed by ghc module -- Code cannot be parsed by ghc module
-- Fallback: try to get information via haskell-src-exts -- 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 p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum
-- Inspect the parse tree to find the signature -- Inspect the parse tree to find the signature
case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsDecl G.RdrName] of 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)))] -> [L loc (G.SigD (Ty.TypeSig names (L _ ty)))] ->
#endif
-- We found a type signature -- We found a type signature
return $ Just $ Signature loc (map G.unLoc names) ty return $ Just $ Signature loc (map G.unLoc names) ty
[L _ (G.InstD _)] -> do [L _ (G.InstD _)] -> do
@ -125,7 +143,12 @@ getSignature modSum lineNo colNo = do
G.TypeFamily -> Open G.TypeFamily -> Open
G.DataFamily -> Data G.DataFamily -> Data
#endif #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 getTyFamVarName x = case x of
L _ (G.UserTyVar n) -> n L _ (G.UserTyVar n) -> n
L _ (G.KindedTyVar n _) -> n L _ (G.KindedTyVar n _) -> n
@ -144,7 +167,8 @@ getSignature modSum lineNo colNo = do
return $ InstanceDecl loc cls return $ InstanceDecl loc cls
-- Get signature from haskell-src-exts -- 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 getSignatureFromHE file lineNo colNo = do
presult <- liftIO $ HE.parseFile file presult <- liftIO $ HE.parseFile file
return $ case presult of return $ case presult of
@ -220,9 +244,11 @@ initialHead1 :: String -> [FnArg] -> [String] -> String
initialHead1 fname args elts = initialHead1 fname args elts =
case initialBodyArgs1 args elts of case initialBodyArgs1 args elts of
[] -> fname [] -> fname
arglist -> if isSymbolName fname arglist
then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist) | isSymbolName fname ->
else fname ++ " " ++ unwords arglist head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)
| otherwise ->
fname ++ " " ++ unwords arglist
initialBodyArgs1 :: [FnArg] -> [String] -> [String] initialBodyArgs1 :: [FnArg] -> [String] -> [String]
initialBodyArgs1 args elts = take (length args) elts 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 instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where
getFnName dflag style name = showOccName dflag style $ Gap.occName name 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.HsParTy (L _ iTy)) = getFnArgs iTy
getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) = getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) =
(if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy
where fnarg ty = case ty of 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.HsParTy (L _ iTy)) -> fnarg iTy
(G.HsFunTy _ _) -> True (G.HsFunTy _ _) -> True
_ -> False _ -> False
@ -301,48 +339,61 @@ refine :: IOish m
-> Int -- ^ Column number. -> Int -- ^ Column number.
-> Expression -- ^ A Haskell expression. -> Expression -- ^ A Haskell expression.
-> GhcModT m String -> 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 where
body = inModuleContext file $ \dflag style -> do handler (SomeException ex) = do
opt <- options gmLog GmDebug "refining" $
modSum <- Gap.fileModSummary file text "" $$ nest 4 (showDoc ex)
p <- G.parseModule modSum emptyResult =<< options
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
-- Look for the variable in the specified position -- Look for the variable in the specified position
findVar :: GhcMonad m => DynFlags -> PprStyle findVar
-> G.TypecheckedModule -> G.TypecheckedSource :: GhcMonad m
-> Int -> Int -> m (Maybe (SrcSpan, String, Type, Bool)) => DynFlags
-> PprStyle
-> G.TypecheckedModule
-> G.TypecheckedSource
-> Int
-> Int
-> m (Maybe (SrcSpan, String, Type, Bool))
findVar dflag style tcm tcs lineNo colNo = findVar dflag style tcm tcs lineNo colNo =
let lst = sortBy (cmp `on` G.getLoc) $ case lst of
listifySpans tcs (lineNo, colNo) :: [G.LHsExpr Id] e@(L _ (G.HsVar i)):others -> do
in case lst of tyInfo <- Gap.getType tcm e
e@(L _ (G.HsVar i)):others -> case tyInfo of
do tyInfo <- Gap.getType tcm e Just (s, typ)
let name = getFnName dflag style i | name == "undefined" || head name == '_' ->
if (name == "undefined" || head name == '_') && isJust tyInfo return $ Just (s, name, typ, b)
then let Just (s,t) = tyInfo where
b = case others of -- If inside an App, we need name = getFnName dflag style i
-- parenthesis -- If inside an App, we need parenthesis
[] -> False b = case others of
L _ (G.HsApp (L _ a1) (L _ a2)):_ -> L _ (G.HsApp (L _ a1) (L _ a2)):_ ->
isSearchedVar i a1 || isSearchedVar i a2 isSearchedVar i a1 || isSearchedVar i a2
_ -> False _ -> False
in return $ Just (s, name, t, b) _ -> return Nothing
else return Nothing _ -> return Nothing
_ -> return Nothing where
lst :: [G.LHsExpr Id]
lst = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo)
infinitePrefixSupply :: String -> [String] infinitePrefixSupply :: String -> [String]
infinitePrefixSupply "undefined" = repeat "undefined" infinitePrefixSupply "undefined" = repeat "undefined"
@ -366,10 +417,11 @@ auto :: IOish m
-> Int -- ^ Line number. -> Int -- ^ Line number.
-> Int -- ^ Column number. -> Int -- ^ Column number.
-> GhcModT m String -> GhcModT m String
auto file lineNo colNo = ghandle handler body auto file lineNo colNo =
where ghandle handler $ runGmlT' [Left file] deferErrors $ do
body = inModuleContext file $ \dflag style -> do
opt <- options opt <- options
style <- getStyle
dflag <- G.getSessionDynFlags
modSum <- Gap.fileModSummary file modSum <- Gap.fileModSummary file
p <- G.parseModule modSum p <- G.parseModule modSum
tcm@TypecheckedModule { tcm@TypecheckedModule {
@ -395,8 +447,11 @@ auto file lineNo colNo = ghandle handler body
djinns <- djinn True (Just minfo) env rty (Max 10) 100000 djinns <- djinn True (Just minfo) env rty (Max 10) 100000
return ( fourInts loc return ( fourInts loc
, map (doParen paren) $ nub (djinnsEmpty ++ djinns)) , map (doParen paren) $ nub (djinnsEmpty ++ djinns))
where
handler (SomeException _) = emptyResult =<< options handler (SomeException ex) = do
gmLog GmDebug "auto-refining" $
text "" $$ nest 4 (showDoc ex)
emptyResult =<< options
-- Functions we do not want in completions -- Functions we do not want in completions
notWantedFuns :: [String] notWantedFuns :: [String]
@ -443,7 +498,11 @@ getPatsForVariable tcs (lineNo, colNo) =
#else #else
:: [G.LMatch Id] :: [G.LMatch Id]
#endif #endif
#if __GLASGOW_HASKELL__ >= 710
(L _ (G.Match _ pats _ _):_) = m
#else
(L _ (G.Match pats _ _):_) = m (L _ (G.Match pats _ _):_) = m
#endif
in (funId, pats) in (funId, pats)
_ -> (error "This should never happen", []) _ -> (error "This should never happen", [])
@ -478,7 +537,13 @@ getBindingsForRecPat (Ty.PrefixCon args) =
getBindingsForRecPat (Ty.InfixCon (L _ a1) (L _ a2)) = getBindingsForRecPat (Ty.InfixCon (L _ a1) (L _ a2)) =
M.union (getBindingsForPat a1) (getBindingsForPat a2) M.union (getBindingsForPat a1) (getBindingsForPat a2)
getBindingsForRecPat (Ty.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) = getBindingsForRecPat (Ty.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) =
getBindingsForRecFields fields getBindingsForRecFields (map unLoc' fields)
where getBindingsForRecFields [] = M.empty where
getBindingsForRecFields (Ty.HsRecField {Ty.hsRecFieldArg = (L _ a)}:fs) = #if __GLASGOW_HASKELL__ >= 710
M.union (getBindingsForPat a) (getBindingsForRecFields fs) 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 module Language.Haskell.GhcMod.Find
#ifndef SPEC #ifndef SPEC
( ( Symbol
Symbol
, SymbolDb , SymbolDb
, loadSymbolDb , loadSymbolDb
, lookupSymbol , lookupSymbol
@ -15,65 +14,51 @@ module Language.Haskell.GhcMod.Find
#endif #endif
where where
import Control.Applicative ((<$>)) import Control.Applicative
import Control.Monad (when, void) import Control.Monad (when, void)
import Data.Function (on) import Data.Function (on)
import Data.List (groupBy, sort) import Data.List (groupBy, sort)
import Data.Maybe (fromMaybe)
import qualified GHC as G import qualified GHC as G
import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Gap (listVisibleModules)
import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils 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 Name (getOccString)
import Module (moduleName)
import System.Directory (doesFileExist, getModificationTime) import System.Directory (doesFileExist, getModificationTime)
import System.FilePath ((</>), takeDirectory) import System.FilePath ((</>))
import System.IO 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 Data.Map (Map)
import qualified Data.Map as M import qualified Data.Map as M
#endif
---------------------------------------------------------------- ----------------------------------------------------------------
-- | Type of function and operation names. -- | Type of function and operation names.
type Symbol = String type Symbol = String
-- | Database from 'Symbol' to \['ModuleString'\]. -- | Database from 'Symbol' to \['ModuleString'\].
data SymbolDb = SymbolDb { data SymbolDb = SymbolDb
table :: Map Symbol [ModuleString] { table :: Map Symbol [ModuleString]
, packageCachePath :: FilePath
, symbolDbCachePath :: FilePath , symbolDbCachePath :: FilePath
} deriving (Show) } deriving (Show)
isOutdated :: SymbolDb -> IO Bool isOutdated :: IOish m => SymbolDb -> GhcModT m Bool
isOutdated db = symbolDbCachePath db `isOlderThan` packageCachePath db isOutdated db =
(liftIO . isOlderThan (symbolDbCachePath db)) =<< timedPackageCaches
----------------------------------------------------------------
-- | When introducing incompatible changes to the 'symbolCache' file format
-- increment this version number.
symbolCacheVersion :: Integer
symbolCacheVersion = 0
-- | Filename of the symbol table cache file.
symbolCache :: String
symbolCache = "ghc-mod-"++ show symbolCacheVersion ++".cache"
---------------------------------------------------------------- ----------------------------------------------------------------
-- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\] -- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]
-- which will be concatenated. 'loadSymbolDb' is called internally. -- which will be concatenated. 'loadSymbolDb' is called internally.
findSymbol :: IOish m => Symbol -> GhcModT m String 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'\] -- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]
-- which will be concatenated. -- which will be concatenated.
@ -81,25 +66,25 @@ lookupSymbol :: IOish m => Symbol -> SymbolDb -> GhcModT m String
lookupSymbol sym db = convert' $ lookupSym sym db lookupSymbol sym db = convert' $ lookupSym sym db
lookupSym :: Symbol -> SymbolDb -> [ModuleString] 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'. -- | Loading a file and creates 'SymbolDb'.
loadSymbolDb :: IOish m => GhcModT m SymbolDb loadSymbolDb :: IOish m => FilePath -> GhcModT m SymbolDb
loadSymbolDb = do loadSymbolDb dir = do
ghcMod <- liftIO ghcModExecutable ghcMod <- liftIO ghcModExecutable
tmpdir <- cradleTempDir <$> cradle readProc <- gmReadProcess
file <- chop <$> readProcess' ghcMod ["dumpsym", tmpdir] file <- liftIO $ chop <$> readProc ghcMod ["dumpsym", dir] ""
!db <- M.fromAscList . map conv . lines <$> liftIO (readFile file) !db <- M.fromAscList . map conv . lines <$> liftIO (readFile file)
return $ SymbolDb { return $ SymbolDb
table = db { table = db
, packageCachePath = takeDirectory file </> packageCache , symbolDbCachePath = file
, symbolDbCachePath = file }
}
where where
conv :: String -> (Symbol,[ModuleString]) conv :: String -> (Symbol, [ModuleString])
conv = read conv = read
chop :: String -> String
chop "" = "" chop "" = ""
chop xs = init xs chop xs = init xs
@ -112,54 +97,52 @@ loadSymbolDb = do
dumpSymbol :: IOish m => FilePath -> GhcModT m String dumpSymbol :: IOish m => FilePath -> GhcModT m String
dumpSymbol dir = do dumpSymbol dir = do
let cache = dir </> symbolCache create <- (liftIO . isOlderThan cache) =<< timedPackageCaches
pkgdb = dir </> packageCache runGmPkgGhc $ do
when create $
create <- liftIO $ cache `isOlderThan` pkgdb liftIO . writeSymbolCache cache =<< getGlobalSymbolTable
when create $ (liftIO . writeSymbolCache cache) =<< getSymbolTable
return $ unlines [cache] return $ unlines [cache]
where
cache = dir </> symbolCacheFile
writeSymbolCache :: FilePath writeSymbolCache :: FilePath
-> [(Symbol,[ModuleString])] -> [(Symbol, [ModuleString])]
-> IO () -> IO ()
writeSymbolCache cache sm = writeSymbolCache cache sm =
void . withFile cache WriteMode $ \hdl -> void . withFile cache WriteMode $ \hdl ->
mapM (hPrint hdl) sm mapM (hPrint hdl) sm
isOlderThan :: FilePath -> FilePath -> IO Bool -- | Check whether given file is older than any file from the given set.
isOlderThan cache file = do -- Returns True if given file does not exist.
exist <- doesFileExist cache isOlderThan :: FilePath -> [TimedFile] -> IO Bool
if not exist then isOlderThan cache files = do
return True exist <- doesFileExist cache
else do if not exist
tCache <- getModificationTime cache then return True
tFile <- getModificationTime file else do
return $ tCache <= tFile -- including equal just in case tCache <- getModificationTime cache
return $ any (tCache <=) $ map tfTime files -- including equal just in case
-- | Browsing all functions in all system/user modules. -- | Browsing all functions in all system modules.
getSymbolTable :: IOish m => GhcModT m [(Symbol,[ModuleString])] getGlobalSymbolTable :: LightGhc [(Symbol, [ModuleString])]
getSymbolTable = do getGlobalSymbolTable = do
ghcModules <- G.packageDbModules True df <- G.getSessionDynFlags
moduleInfos <- mapM G.getModuleInfo ghcModules let mods = listVisibleModules df
let modules = do moduleInfos <- mapM G.getModuleInfo mods
m <- ghcModules return $ collectModules
let moduleName = G.moduleNameString $ G.moduleName m $ extractBindings `concatMap` (moduleInfos `zip` mods)
-- modulePkg = G.packageIdString $ G.modulePackageId m
return moduleName
return $ collectModules extractBindings :: (Maybe G.ModuleInfo, G.Module)
$ extractBindings `concatMap` (moduleInfos `zip` modules)
extractBindings :: (Maybe G.ModuleInfo, ModuleString)
-> [(Symbol, ModuleString)] -> [(Symbol, ModuleString)]
extractBindings (Nothing,_) = [] extractBindings (Nothing, _) = []
extractBindings (Just inf,mdlname) = extractBindings (Just inf, mdl) =
map (\name -> (getOccString name, mdlname)) names map (\name -> (getOccString name, modStr)) names
where where
names = G.modInfoExports inf names = G.modInfoExports inf
modStr = ModuleString $ moduleNameString $ moduleName mdl
collectModules :: [(Symbol,ModuleString)] collectModules :: [(Symbol, ModuleString)]
-> [(Symbol,[ModuleString])] -> [(Symbol, [ModuleString])]
collectModules = map tieup . groupBy ((==) `on` fst) . sort collectModules = map tieup . groupBy ((==) `on` fst) . sort
where where
tieup x = (head (map fst x), map snd x) 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 , showSeverityCaption
, setCabalPkg , setCabalPkg
, setHideAllPackages , setHideAllPackages
, addPackageFlags
, setDeferTypeErrors , setDeferTypeErrors
, setWarnTypedHoles , setWarnTypedHoles
, setDumpSplices , setDumpSplices
@ -33,14 +32,15 @@ module Language.Haskell.GhcMod.Gap (
, fileModSummary , fileModSummary
, WarnFlags , WarnFlags
, emptyWarnFlags , emptyWarnFlags
, benchmarkBuildInfo
, benchmarkTargets
, toModuleString
, GLMatch , GLMatch
, GLMatchI , GLMatchI
, getClass , getClass
, occName , occName
, setFlags , listVisibleModuleNames
, listVisibleModules
, lookupModulePackageInAllPackages
, Language.Haskell.GhcMod.Gap.isSynTyCon
, parseModuleHeader
) where ) where
import Control.Applicative hiding (empty) import Control.Applicative hiding (empty)
@ -49,15 +49,15 @@ import CoreSyn (CoreExpr)
import Data.List (intersperse) import Data.List (intersperse)
import Data.Maybe (catMaybes) import Data.Maybe (catMaybes)
import Data.Time.Clock (UTCTime) import Data.Time.Clock (UTCTime)
import Data.Traversable hiding (mapM)
import DataCon (dataConRepType) import DataCon (dataConRepType)
import Desugar (deSugarExpr) import Desugar (deSugarExpr)
import DynFlags import DynFlags
import ErrUtils import ErrUtils
import Exception
import FastString import FastString
import GhcMonad import GhcMonad
import HscTypes import HscTypes
import Language.Haskell.GhcMod.GHCChoice
import Language.Haskell.GhcMod.Types
import NameSet import NameSet
import OccName import OccName
import Outputable import Outputable
@ -65,8 +65,8 @@ import PprTyThing
import StringBuffer import StringBuffer
import TcType import TcType
import Var (varType) import Var (varType)
import System.Directory
import qualified Distribution.PackageDescription as P
import qualified InstEnv import qualified InstEnv
import qualified Pretty import qualified Pretty
import qualified StringBuffer as SB import qualified StringBuffer as SB
@ -88,11 +88,24 @@ import Data.Convertible
import RdrName (rdrNameOcc) import RdrName (rdrNameOcc)
#endif #endif
#if __GLASGOW_HASKELL__ < 710
import UniqFM (eltsUFM)
import Module
#endif
#if __GLASGOW_HASKELL__ >= 704 #if __GLASGOW_HASKELL__ >= 704
import qualified Data.IntSet as I (IntSet, empty) import qualified Data.IntSet as I (IntSet, empty)
import qualified Distribution.ModuleName as M (ModuleName,toFilePath)
#endif #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] 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] fOptions = [option | (option,_,_) <- fFlags]
++ [option | (option,_,_) <- fWarningFlags] ++ [option | (option,_,_) <- fWarningFlags]
++ [option | (option,_,_) <- fLangFlags] ++ [option | (option,_,_) <- fLangFlags]
@ -187,9 +204,11 @@ fOptions = [option | (option,_,_,_) <- fFlags]
---------------------------------------------------------------- ----------------------------------------------------------------
fileModSummary :: GhcMonad m => FilePath -> m ModSummary fileModSummary :: GhcMonad m => FilePath -> m ModSummary
fileModSummary file = do fileModSummary file' = do
mss <- getModuleGraph 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 return ms
withContext :: GhcMonad m => m a -> m a withContext :: GhcMonad m => m a -> m a
@ -202,26 +221,31 @@ withContext action = gbracket setup teardown body
action action
topImports = do topImports = do
mss <- getModuleGraph mss <- getModuleGraph
ms <- map modName <$> filterM isTop mss mns <- map modName <$> filterM isTop mss
let ii = map IIModule mns
#if __GLASGOW_HASKELL__ >= 704 #if __GLASGOW_HASKELL__ >= 704
return ms return ii
#else #else
return (ms,[]) return (ii,[])
#endif #endif
isTop mos = lookupMod mos ||> returnFalse isTop mos = lookupMod mos ||> returnFalse
lookupMod mos = lookupModule (ms_mod_name mos) Nothing >> return True lookupMod mos = lookupModule (ms_mod_name mos) Nothing >> return True
returnFalse = return False returnFalse = return False
#if __GLASGOW_HASKELL__ >= 706 #if __GLASGOW_HASKELL__ >= 706
modName = IIModule . moduleName . ms_mod modName = moduleName . ms_mod
setCtx = setContext setCtx = setContext
#elif __GLASGOW_HASKELL__ >= 704 #elif __GLASGOW_HASKELL__ >= 704
modName = IIModule . ms_mod modName = ms_mod
setCtx = setContext setCtx = setContext
#else #else
modName = ms_mod modName = ms_mod
setCtx = uncurry setContext setCtx = uncurry setContext
#endif #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 showSeverityCaption :: Severity -> String
#if __GLASGOW_HASKELL__ >= 706 #if __GLASGOW_HASKELL__ >= 706
showSeverityCaption SevWarning = "Warning: " showSeverityCaption SevWarning = "Warning: "
@ -249,12 +273,6 @@ setHideAllPackages df = gopt_set df Opt_HideAllPackages
setHideAllPackages df = dopt_set df Opt_HideAllPackages setHideAllPackages df = dopt_set df Opt_HideAllPackages
#endif #endif
addPackageFlags :: [Package] -> DynFlags -> DynFlags
addPackageFlags pkgs df =
df { packageFlags = packageFlags df ++ expose `map` pkgs }
where
expose pkg = ExposePackageId $ showPkgId pkg
---------------------------------------------------------------- ----------------------------------------------------------------
setDumpSplices :: DynFlags -> DynFlags setDumpSplices :: DynFlags -> DynFlags
@ -310,8 +328,8 @@ filterOutChildren get_thing xs
where where
implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)] implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
infoThing :: GhcMonad m => String -> m SDoc infoThing :: GhcMonad m => Expression -> m SDoc
infoThing str = do infoThing (Expression str) = do
names <- parseName str names <- parseName str
#if __GLASGOW_HASKELL__ >= 708 #if __GLASGOW_HASKELL__ >= 708
mb_stuffs <- mapM (getInfo False) names 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 #if __GLASGOW_HASKELL__ >= 708
type GLMatch = LMatch RdrName (LHsExpr RdrName) type GLMatch = LMatch RdrName (LHsExpr RdrName)
type GLMatchI = LMatch Id (LHsExpr Id) type GLMatchI = LMatch Id (LHsExpr Id)
@ -445,7 +440,12 @@ type GLMatchI = LMatch Id
#endif #endif
getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan) 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)' -- 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) 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) -- Instance declarations of sort 'instance F G' (no variables)
@ -464,12 +464,74 @@ occName :: RdrName -> OccName
occName = rdrNameOcc occName = rdrNameOcc
#endif #endif
----------------------------------------------------------------
---------------------------------------------------------------- ----------------------------------------------------------------
setFlags :: DynFlags -> DynFlags #if __GLASGOW_HASKELL__ < 710
#if __GLASGOW_HASKELL__ >= 708 -- Copied from ghc/InteractiveUI.hs
setFlags df = df `gopt_unset` Opt_SpecConstr -- consume memory if -O2 allExposedPackageConfigs :: DynFlags -> [PackageConfig]
#else allExposedPackageConfigs df = filter exposed $ eltsUFM $ pkgIdMap $ pkgState df
setFlags = id
allExposedModules :: DynFlags -> [ModuleName]
allExposedModules df = concat $ map exposedModules $ allExposedPackageConfigs df
listVisibleModuleNames :: DynFlags -> [ModuleName]
listVisibleModuleNames = allExposedModules
#endif #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 , ghcPkgDbStackOpts
, ghcDbStackOpts , ghcDbStackOpts
, ghcDbOpt , ghcDbOpt
, fromInstalledPackageId
, fromInstalledPackageId'
, getPackageDbStack , getPackageDbStack
, getPackageCachePaths , getPackageCachePaths
) where ) where
import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt) import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt)
import Control.Applicative ((<$>)) import Control.Applicative
import Data.List (intercalate)
import Data.List.Split (splitOn) import Data.List.Split (splitOn)
import Data.Maybe import Data.Maybe
import Distribution.Package (InstalledPackageId(..))
import Exception (handleIO) import Exception (handleIO)
import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Types
import System.Directory (doesDirectoryExist, getAppUserDataDirectory) import System.Directory (doesDirectoryExist, getAppUserDataDirectory)
import System.FilePath ((</>)) 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 :: Int
ghcVersion = read cProjectVersionInt 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 -- | Get options needed to add a list of package dbs to ghc-pkg's db stack
@ -85,11 +59,24 @@ ghcDbOpt (PackageDb pkgDb)
---------------------------------------------------------------- ----------------------------------------------------------------
getPackageDbStack :: IOish m => GhcModT m [GhcPkgDb]
getPackageDbStack = do
crdl <- cradle
mCusPkgStack <- getCustomPkgDbStack
stack <- case cradleProjectType crdl of
PlainProject ->
return [GlobalDb, UserDb]
SandboxProject -> do
Just db <- liftIO $ getSandboxDb $ cradleRootDir crdl
return $ [GlobalDb, db]
CabalProject ->
getCabalPackageDbStack
return $ fromMaybe stack mCusPkgStack
getPackageCachePaths :: FilePath -> Cradle -> IO [FilePath] getPackageCachePaths :: IOish m => FilePath -> GhcModT m [FilePath]
getPackageCachePaths sysPkgCfg crdl = getPackageCachePaths sysPkgCfg = do
catMaybes <$> resolvePackageConfig sysPkgCfg `mapM` cradlePkgDbStack crdl pkgDbStack <- getPackageDbStack
catMaybes <$> (liftIO . resolvePackageConfig sysPkgCfg) `mapM` pkgDbStack
-- TODO: use PkgConfRef -- TODO: use PkgConfRef
--- Copied from ghc module `Packages' unfortunately it's not exported :/ --- 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 , types
) where ) where
import Control.Applicative ((<$>)) import Control.Applicative
import Data.Function (on) import Data.Function (on)
import Data.List (sortBy) import Data.List (sortBy)
import Data.Maybe (catMaybes) import Data.Maybe (catMaybes)
import System.FilePath
import Exception (ghandle, SomeException(..)) import Exception (ghandle, SomeException(..))
import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan, Type) import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan, Type)
import Prelude
import qualified GHC as G 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 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.Monad
import Language.Haskell.GhcMod.SrcUtils import Language.Haskell.GhcMod.SrcUtils
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Convert
---------------------------------------------------------------- ----------------------------------------------------------------
@ -25,14 +30,22 @@ info :: IOish m
=> FilePath -- ^ A target file. => FilePath -- ^ A target file.
-> Expression -- ^ A Haskell expression. -> Expression -- ^ A Haskell expression.
-> GhcModT m String -> GhcModT m String
info file expr = do info file expr =
opt <- options ghandle handler $
convert opt <$> ghandle handler body runGmlT' [Left file] deferErrors $
withContext $
convert <$> options <*> body
where where
body = inModuleContext file $ \dflag style -> do handler (SomeException ex) = do
sdoc <- Gap.infoThing expr gmLog GmException "info" $ text "" $$ nest 4 (showDoc ex)
return $ showPage dflag style sdoc convert' "Cannot show info"
handler (SomeException _) = return "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 -- ^ Line number.
-> Int -- ^ Column number. -> Int -- ^ Column number.
-> GhcModT m String -> GhcModT m String
types file lineNo colNo = do types file lineNo colNo =
opt <- options ghandle handler $
convert opt <$> ghandle handler body runGmlT' [Left file] deferErrors $
where withContext $ do
body = inModuleContext file $ \dflag style -> do crdl <- cradle
modSum <- Gap.fileModSummary file modSum <- Gap.fileModSummary (cradleCurrentDir crdl </> file)
srcSpanTypes <- getSrcSpanType modSum lineNo colNo srcSpanTypes <- getSrcSpanType modSum lineNo colNo
return $ map (toTup dflag style) $ sortBy (cmp `on` fst) srcSpanTypes dflag <- G.getSessionDynFlags
handler (SomeException _) = return [] st <- getStyle
convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes
where
handler (SomeException ex) = do
gmLog GmException "types" $ showDoc ex
return []
getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)] getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)]
getSrcSpanType modSum lineNo colNo = do getSrcSpanType modSum lineNo colNo = do
p <- G.parseModule modSum p <- G.parseModule modSum
tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id] let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id]
es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id] es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id]
ps = listifySpans tcs (lineNo, colNo) :: [LPat Id] ps = listifySpans tcs (lineNo, colNo) :: [LPat Id]
bts <- mapM (getType tcm) bs bts <- mapM (getType tcm) bs
ets <- mapM (getType tcm) es ets <- mapM (getType tcm) es
pts <- mapM (getType tcm) ps pts <- mapM (getType tcm) ps
return $ catMaybes $ concat [ets, bts, pts] return $ catMaybes $ concat [ets, bts, pts]

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

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

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

@ -1,31 +1,33 @@
{-# LANGUAGE CPP #-}
module Language.Haskell.GhcMod.Logger ( module Language.Haskell.GhcMod.Logger (
withLogger withLogger
, withLoggerTwice , withLogger'
, checkErrorPrefix , checkErrorPrefix
, errsToStr
, errBagToStrList
) where ) where
import Bag (Bag, bagToList, emptyBag, consBag, filterBag, unionBags) import Control.Arrow
import Control.Applicative ((<$>)) import Control.Applicative
import Data.List (isPrefixOf)
import Data.Maybe (fromMaybe)
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) import Data.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 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] type Builder = [String] -> [String]
@ -39,178 +41,94 @@ emptyLog = Log [] id
newLogRef :: IO LogRef newLogRef :: IO LogRef
newLogRef = LogRef <$> newIORef emptyLog newLogRef = LogRef <$> newIORef emptyLog
readAndClearLogRef :: IOish m => LogRef -> GhcModT m String readAndClearLogRef :: LogRef -> IO [String]
readAndClearLogRef (LogRef ref) = do readAndClearLogRef (LogRef ref) = do
Log _ b <- liftIO $ readIORef ref Log _ b <- readIORef ref
liftIO $ writeIORef ref emptyLog writeIORef ref emptyLog
convert' (b []) return $ b []
appendLogRef :: DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO () appendLogRef :: 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 where
l = ppMsg src sev df style msg l = ppMsg src sev df st msg
update lg@(Log ls b) update lg@(Log ls b)
| l `elem` ls = lg | l `elem` ls = lg
| otherwise = Log (l:ls) (b . (l:)) | 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 -- | Set the session flag (e.g. "-Wall" or "-w:") then
-- executes a body. Logged messages are returned as 'String'. -- executes a body. Logged messages are returned as 'String'.
-- Right is success and Left is failure. -- Right is success and Left is failure.
withLogger :: IOish m withLogger :: (GmGhc m, GmEnv m)
=> (DynFlags -> DynFlags) => (DynFlags -> DynFlags)
-> GhcModT m () -> m a
-> GhcModT m (Either String String) -> m (Either String (String, a))
withLogger setDF body = ghandle sourceError $ do withLogger f action = do
logref <- liftIO newLogRef env <- G.getSession
wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options opts <- options
withDynFlags (setLogger logref . setDF) $ let conv = convert opts
withCmdFlags wflags $ do eres <- withLogger' env $ \setDf ->
body withDynFlags (f . setDf) action
Right <$> readAndClearLogRef logref return $ either (Left . conv) (Right . first conv) eres
withLogger' :: IOish m
=> HscEnv -> ((DynFlags -> DynFlags) -> m a) -> m (Either [String] ([String], a))
withLogger' env action = do
logref <- liftIO $ newLogRef
let dflags = hsc_dflags env
pu = icPrintUnqual dflags (hsc_IC env)
st = mkUserStyle pu AllTheWay
fn df = setLogger logref df
a <- gcatches (Right <$> action fn) (handlers dflags st)
ls <- liftIO $ readAndClearLogRef logref
return $ ((,) ls <$> a)
where where
setLogger logref df = Gap.setLogAction df $ appendLogRef df logref setLogger logref df = Gap.setLogAction df $ appendLogRef df logref
handlers df st = [
GHandler $ \ex -> return $ Left $ sourceError df st ex,
GHandler $ \ex -> return $ Left [render $ ghcExceptionDoc ex]
]
withLoggerTwice :: IOish m errBagToStrList :: HscEnv -> Bag ErrMsg -> [String]
=> (DynFlags -> DynFlags) errBagToStrList env errs = let
-> GhcModT m () dflags = hsc_dflags env
-> (DynFlags -> DynFlags) pu = icPrintUnqual dflags (hsc_IC env)
-> GhcModT m () st = mkUserStyle pu AllTheWay
-> GhcModT m (Either String String) in errsToStr dflags st $ bagToList errs
withLoggerTwice setDF1 body1 setDF2 body2 = do
err1 <- ghandle sourceErrorBag $ do
logref <- liftIO newLogBagRef
wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options
withDynFlags (setLogger logref . setDF1) $
withCmdFlags wflags $ do
body1
Right <$> readAndClearLogBagRef logref
err2 <- ghandle sourceErrorBag $ do
logref <- liftIO newLogBagRef
wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options
withDynFlags (setLogger logref . setDF2) $
withCmdFlags wflags $ do
body2
Right <$> readAndClearLogBagRef logref
-- Merge errors and warnings
dflags <- G.getSessionDynFlags
style <- getStyle
case (err1, err2) of
(Right b1, Right b2) -> do let (warn1,_) = mergeErrors dflags style b1 b2
errAndWarnBagToStr Right emptyBag (warn1 `unionBags` b2)
(Left b1, Right b2) -> do let (err,warn) = mergeErrors dflags style b1 b2
errAndWarnBagToStr Right err warn
(Right b1, Left b2) -> do let (err,warn) = mergeErrors dflags style b2 b1
errAndWarnBagToStr Right err warn
(Left b1, Left b2) -> do let (err1',err2') = mergeErrors dflags style b1 b2
errAndWarnBagToStr Right (err1' `unionBags` err2') emptyBag
where
setLogger logref df = Gap.setLogAction df $ appendLogBagRef df logref
---------------------------------------------------------------- ----------------------------------------------------------------
-- | Converting 'SourceError' to 'String'. -- | Converting 'SourceError' to 'String'.
sourceError :: IOish m => SourceError -> GhcModT m (Either String String) sourceError :: DynFlags -> PprStyle -> SourceError -> [String]
sourceError err = errBagToStr (srcErrorMessages err) sourceError df st src_err = errsToStr df st $ reverse $ bagToList $ srcErrorMessages src_err
errBagToStr :: IOish m => Bag ErrMsg -> GhcModT m (Either String String) errsToStr :: DynFlags -> PprStyle -> [ErrMsg] -> [String]
errBagToStr = errBagToStr' Left errsToStr df st = map (ppErrMsg df st)
errBagToStr' :: IOish m => (String -> a) -> Bag ErrMsg -> GhcModT m a
errBagToStr' f err = do
dflags <- G.getSessionDynFlags
style <- getStyle
ret <- convert' (errBagToStrList dflags style err)
return $ f ret
errAndWarnBagToStr :: IOish m => (String -> a) -> Bag ErrMsg -> Bag WarnMsg -> GhcModT m a
errAndWarnBagToStr f err warn = do
dflags <- G.getSessionDynFlags
-- style <- toGhcModT getStyle
#if __GLASGOW_HASKELL__ >= 706
let style = mkErrStyle dflags neverQualify
#else
let style = mkErrStyle neverQualify
#endif
ret <- convert' $ nub (errBagToStrList dflags style err ++ warnBagToStrList dflags style warn)
return $ f ret
errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String]
errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList
warnBagToStrList :: DynFlags -> PprStyle -> Bag WarnMsg -> [String]
warnBagToStrList dflag style = map (ppWarnMsg dflag style) . reverse . bagToList
sourceErrorBag :: IOish m => SourceError -> GhcModT m (Either (Bag ErrMsg) (Bag WarnMsg))
sourceErrorBag err = return $ Left (srcErrorMessages err)
mergeErrors :: DynFlags -> PprStyle -> Bag ErrMsg -> Bag ErrMsg -> (Bag ErrMsg, Bag ErrMsg)
mergeErrors dflag style b1 b2 =
let b1Msgs = map (\err1 -> let m = ppWarnMsg dflag style err1 in (m, head $ lines m))
(bagToList b1)
mustBeB2 = \err2 -> let msg2 = ppWarnMsg dflag style err2
line2 = head $ lines msg2
in not . isJust $ find (\(msg1, line1) -> msg1 == msg2 || (line1 == line2 && isHoleMsg line1)) b1Msgs
in (b1, filterBag mustBeB2 b2)
isHoleMsg :: String -> Bool
isHoleMsg = isInfixOf "Found hole"
---------------------------------------------------------------- ----------------------------------------------------------------
ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String ppErrMsg :: 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 where
spn = Gap.errorMsgSpan err spn = Gap.errorMsgSpan err
msg = errMsgShortDoc err msg = errMsgShortDoc err
ext = showPage dflag style (errMsgExtraInfo err) ext = showPage dflag st (errMsgExtraInfo err)
ppWarnMsg :: DynFlags -> PprStyle -> ErrMsg -> String
ppWarnMsg dflag style err = ppMsg spn G.SevWarning dflag style msg ++ (if null ext then "" else "\n" ++ ext)
where
spn = Gap.errorMsgSpan err
msg = errMsgShortDoc err
ext = showPage dflag style (errMsgExtraInfo err)
ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String
ppMsg spn sev dflag style msg = prefix ++ cts ppMsg spn sev dflag st msg = prefix ++ cts
where where
cts = showPage dflag style msg cts = showPage dflag st msg
prefix = ppMsgPrefix spn sev dflag style cts prefix = ppMsgPrefix spn sev dflag st cts
ppMsgPrefix :: SrcSpan -> Severity-> DynFlags -> PprStyle -> String -> String ppMsgPrefix :: SrcSpan -> Severity-> DynFlags -> PprStyle -> String -> String
ppMsgPrefix spn sev dflag _style cts = ppMsgPrefix spn sev dflag _st cts =
let defaultPrefix let defaultPrefix
| Gap.isDumpSplices dflag = "" | Gap.isDumpSplices dflag = ""
| otherwise = checkErrorPrefix | 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 module Language.Haskell.GhcMod.Modules (modules) where
import Control.Applicative ((<$>)) import Control.Arrow
import Control.Exception (SomeException(..)) import Data.List
import Data.List (nub, sort)
import qualified GHC as G
import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Packages (pkgIdMap, exposedModules, sourcePackageId, display) import Language.Haskell.GhcMod.Monad
import UniqFM (eltsUFM) import Language.Haskell.GhcMod.Gap ( listVisibleModuleNames
, lookupModulePackageInAllPackages
)
import qualified GHC as G
---------------------------------------------------------------- ----------------------------------------------------------------
-- | Listing installed modules. -- | Listing installed modules.
modules :: IOish m => GhcModT m String modules :: (IOish m, GmEnv m, GmState m, GmLog m) => m String
modules = do modules = do
opt <- options Options { detailed } <- options
convert opt . arrange opt <$> (getModules `G.gcatch` handler) df <- runGmPkgGhc G.getSessionDynFlags
where let mns = listVisibleModuleNames df
getModules = getExposedModules <$> G.getSessionDynFlags pmnss = map (first moduleNameString) $ zip mns (modulePkg df `map` mns)
getExposedModules = concatMap exposedModules' convert' $ nub [ if detailed then pkg ++ " " ++ mn else mn
. eltsUFM . pkgIdMap . G.pkgState | (mn, pkgs) <- pmnss, pkg <- pkgs ]
exposedModules' p = where
map G.moduleNameString (exposedModules p) modulePkg df = lookupModulePackageInAllPackages df
`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 []

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

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

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 #-} -- ghc-mod: Making Haskell development *more* fun
module Language.Haskell.GhcMod.PathsAndFiles where -- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
module Language.Haskell.GhcMod.PathsAndFiles (
module Language.Haskell.GhcMod.PathsAndFiles
, module Language.Haskell.GhcMod.Caching
) where
import Config (cProjectVersion)
import Control.Applicative import Control.Applicative
import Control.Monad import Control.Monad
import Data.List import Data.List
import Data.Char import Data.Char
import Data.Maybe import Data.Maybe
import Data.Traversable (traverse) import Data.Traversable hiding (mapM)
import Language.Haskell.GhcMod.Types import Distribution.Helper (buildPlatform)
import System.Directory import System.Directory
import System.FilePath import System.FilePath
import System.Process
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Error
import Language.Haskell.GhcMod.Caching
import qualified Language.Haskell.GhcMod.Utils as U import qualified Language.Haskell.GhcMod.Utils as U
import Utils (mightExist)
import Distribution.Simple.BuildPaths (defaultDistPref) import Prelude
import Distribution.Simple.Configure (localBuildInfoFile)
-- | Guaranteed to be a path to a directory with no trailing slash. -- | Guaranteed to be a path to a directory with no trailing slash.
type DirPath = FilePath type DirPath = FilePath
@ -23,40 +44,111 @@ type DirPath = FilePath
-- | Guaranteed to be the name of a file only (no slashes). -- | Guaranteed to be the name of a file only (no slashes).
type FileName = String 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 -- | @findCabalFiles dir@. Searches for a @.cabal@ files in @dir@'s parent
-- directories. The first parent directory containing more than one cabal file -- 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 -- is assumed to be the project directory. If only one cabal file exists in this
-- directory it is returned otherwise @findCabalFiles@ throws 'GMENoCabalFile' -- directory it is returned otherwise @findCabalFiles@ throws 'GMENoCabalFile'
-- or 'GMETooManyCabalFiles' -- or 'GMETooManyCabalFiles'
findCabalFile :: FilePath -> IO (Maybe FilePath) findCabalFile :: FilePath -> IO (Maybe FilePath)
findCabalFile directory = do findCabalFile dir = do
-- Look for cabal files in @dir@ and all it's parent directories -- List of directories and all cabal file candidates
dcs <- getCabalFiles `zipMapM` parents directory dcs <- findFileInParentsP isCabalFile dir :: IO ([(DirPath, [FileName])])
-- Extract first non-empty list, which represents a directory with cabal let css = uncurry appendDir `map` dcs :: [[FilePath]]
-- files. case find (not . null) css of
case find (not . null) $ uncurry appendDir `map` dcs of Nothing -> return Nothing
Just [] -> throw $ GMENoCabalFile
Just cfs@(_:_:_) -> throw $ GMETooManyCabalFiles cfs Just cfs@(_:_:_) -> throw $ GMETooManyCabalFiles cfs
a -> return $ head <$> a Just (a:_) -> return (Just a)
Just [] -> error "findCabalFile"
where where
appendDir :: DirPath -> [FileName] -> [FilePath] 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 where
isCabalFile f = do fixPkgDbVer bp dir =
exists <- doesFileExist $ dir </> f case takeFileName dir == ghcSandboxPkgDbDir bp of
return (exists && takeExtension' f == ".cabal") True -> dir
False -> takeDirectory dir </> ghcSandboxPkgDbDir bp
takeExtension' p = if takeFileName p == takeExtension p -- | Extract the sandbox package db directory from the cabal.sandbox.config
then "" -- file. Exception is thrown if the sandbox config file is broken.
else takeExtension p 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 :: 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@. -- | @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 :: Cradle -> FilePath
setupConfigFile crdl = cradleRootDir crdl </> setupConfigPath setupConfigFile crdl = cradleRootDir crdl </> setupConfigPath
sandboxConfigFile :: FilePath
sandboxConfigFile = "cabal.sandbox.config"
-- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@ -- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@
setupConfigPath :: FilePath 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 :: String
packageCache = "package.cache" 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.Monad
import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.Utils
import Control.Applicative ((<$>)) import Control.Applicative
import Prelude
-- | Obtaining the package name and the doc path of a module. -- | Obtaining the package name and the doc path of a module.
pkgDoc :: IOish m => String -> GhcModT m String pkgDoc :: IOish m => String -> GhcModT m String
pkgDoc mdl = do pkgDoc mdl = do
c <- cradle pkgDbStack <- getPackageDbStack
pkg <- trim <$> readProcess' "ghc-pkg" (toModuleOpts c) pkg <- liftIO $ trim <$> readProcess "ghc-pkg" (toModuleOpts pkgDbStack) ""
if pkg == "" then if pkg == "" then
return "\n" return "\n"
else do else do
htmlpath <- readProcess' "ghc-pkg" (toDocDirOpts pkg c) htmlpath <- liftIO $ readProcess "ghc-pkg" (toDocDirOpts pkg pkgDbStack) ""
let ret = pkg ++ " " ++ drop 14 htmlpath let ret = pkg ++ " " ++ drop 14 htmlpath
return ret return ret
where where
toModuleOpts c = ["find-module", mdl, "--simple-output"] toModuleOpts dbs = ["find-module", mdl, "--simple-output"]
++ ghcPkgDbStackOpts (cradlePkgDbStack c) ++ ghcPkgDbStackOpts dbs
toDocDirOpts pkg c = ["field", pkg, "haddock-html"] toDocDirOpts pkg dbs = ["field", pkg, "haddock-html"]
++ ghcPkgDbStackOpts (cradlePkgDbStack c) ++ ghcPkgDbStackOpts dbs
trim = takeWhile (`notElem` " \n") 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 module Language.Haskell.GhcMod.SrcUtils where
import Control.Applicative ((<$>)) import Control.Applicative
import CoreUtils (exprType) import CoreUtils (exprType)
import Data.Generics import Data.Generics
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
@ -13,15 +13,13 @@ import qualified GHC as G
import GHC.SYB.Utils (Stage(..), everythingStaged) import GHC.SYB.Utils (Stage(..), everythingStaged)
import GhcMonad import GhcMonad
import qualified Language.Haskell.Exts.Annotated as HE import qualified Language.Haskell.Exts.Annotated as HE
import Language.Haskell.GhcMod.Doc (showOneLine, getStyle) import Language.Haskell.GhcMod.Doc
import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.Gap
import Language.Haskell.GhcMod.Gap (HasType(..), setWarnTypedHoles, setDeferTypeErrors)
import qualified Language.Haskell.GhcMod.Gap as Gap import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Monad (IOish, GhcModT)
import Language.Haskell.GhcMod.Target (setTargetFiles)
import OccName (OccName) import OccName (OccName)
import Outputable (PprStyle) import Outputable (PprStyle)
import TcHsSyn (hsPatType) import TcHsSyn (hsPatType)
import Prelude
---------------------------------------------------------------- ----------------------------------------------------------------
@ -83,22 +81,6 @@ typeSigInRangeHE _ _ _= False
pretty :: DynFlags -> PprStyle -> Type -> String pretty :: DynFlags -> PprStyle -> Type -> String
pretty dflag style = showOneLine dflag style . Gap.typeForUser 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 :: DynFlags -> PprStyle -> G.Name -> String
showName dflag style name = showOneLine dflag style $ Gap.nameForUser name showName dflag style name = showOneLine dflag style $ Gap.nameForUser name

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

@ -1,60 +1,486 @@
{-# LANGUAGE CPP #-} -- ghc-mod: Making Haskell development *more* fun
module Language.Haskell.GhcMod.Target ( -- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
setTargetFiles --
) where -- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
{-# LANGUAGE CPP, ViewPatterns, NamedFieldPuns, RankNTypes #-}
module Language.Haskell.GhcMod.Target where
import Control.Arrow
import Control.Applicative
import Control.Category ((.))
import Control.Monad.Reader (runReaderT)
import GHC
import GHC.Paths (libdir)
import StaticFlags
import SysTools
import DynFlags
import HscMain
import HscTypes
import Control.Applicative ((<$>))
import Control.Monad (forM, void, (>=>))
import DynFlags (ExtensionFlag(..), xopt)
import GHC (LoadHowMuch(..))
import qualified GHC as G
import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.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. -- | Set the files as targets and load them.
setTargetFiles :: IOish m => [FilePath] -> GhcModT m () loadTargets :: IOish m => [String] -> GmlT m ()
setTargetFiles files = do loadTargets filesOrModules = do
targets <- forM files $ \file -> G.guessTarget file Nothing gmLog GmDebug "loadTargets" $
G.setTargets targets text "Loading" <+>: fsep (map text filesOrModules)
targets <- forM filesOrModules (flip guessTarget Nothing)
setTargets targets
mode <- getCompilerMode mode <- getCompilerMode
if mode == Intelligent then if mode == Intelligent
loadTargets Intelligent then loadTargets' Intelligent
else do else do
mdls <- G.depanal [] False mdls <- depanal [] False
let fallback = needsFallback mdls let fallback = needsFallback mdls
if fallback then do if fallback then do
resetTargets targets resetTargets targets
setIntelligent 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 else
loadTargets Simple loadTargets' Simple
where where
loadTargets Simple = do loadTargets' Simple = do
-- Reporting error A and error B void $ load LoadAllTargets
void $ G.load LoadAllTargets mapM_ (parseModule >=> typecheckModule >=> desugarModule) =<< getModuleGraph
mss <- filter (\x -> G.ms_hspp_file x `elem` files) <$> G.getModuleGraph
-- Reporting error B and error C loadTargets' Intelligent = do
mapM_ (G.parseModule >=> G.typecheckModule >=> G.desugarModule) mss df <- getSessionDynFlags
-- Error B duplicates. But we cannot ignore both error reportings, void $ setSessionDynFlags (setModeIntelligent df)
-- sigh. So, the logger makes log messages unique by itself. void $ load LoadAllTargets
loadTargets Intelligent = do
df <- G.getSessionDynFlags
void $ G.setSessionDynFlags (setModeIntelligent df)
void $ G.load LoadAllTargets
resetTargets targets = do resetTargets targets = do
G.setTargets [] setTargets []
void $ G.load LoadAllTargets void $ load LoadAllTargets
G.setTargets targets setTargets targets
setIntelligent = do setIntelligent = do
newdf <- setModeIntelligent <$> G.getSessionDynFlags newdf <- setModeIntelligent <$> getSessionDynFlags
void $ G.setSessionDynFlags newdf void $ setSessionDynFlags newdf
setCompilerMode Intelligent setCompilerMode Intelligent
needsFallback :: G.ModuleGraph -> Bool needsFallback :: ModuleGraph -> Bool
needsFallback = any $ \ms -> needsFallback = any $ \ms ->
let df = G.ms_hspp_opts ms in let df = ms_hspp_opts ms in
Opt_TemplateHaskell `xopt` df Opt_TemplateHaskell `xopt` df
|| Opt_QuasiQuotes `xopt` df || Opt_QuasiQuotes `xopt` df
#if __GLASGOW_HASKELL__ >= 708 #if __GLASGOW_HASKELL__ >= 708
|| (Opt_PatternSynonyms `xopt` df) || (Opt_PatternSynonyms `xopt` df)
#endif #endif
cabalResolvedComponents :: (IOish m) =>
GhcModT m (Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath)))
cabalResolvedComponents = do
crdl@(Cradle{..}) <- cradle
comps <- mapM (resolveEntrypoint crdl) =<< getComponents
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.Trans.Control (MonadBaseControl)
import Control.Monad.Error (Error(..))
import qualified Control.Monad.IO.Class as MTL
import Control.Exception (Exception)
import Control.Applicative
import Control.Concurrent
import Control.Monad
import Data.Serialize
import Data.Version
import Data.List (intercalate) import Data.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 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 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 -- | A constraint alias (-XConstraintKinds) to make functions dealing with
-- 'GhcModT' somewhat cleaner. -- 'GhcModT' somewhat cleaner.
@ -16,6 +49,18 @@ import PackageConfig (PackageConfig)
-- the exported API so users have the option to use a custom inner monad. -- 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) 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. -- | Output style.
data OutputStyle = LispStyle -- ^ S expression style. data OutputStyle = LispStyle -- ^ S expression style.
| PlainStyle -- ^ Plain textstyle. | PlainStyle -- ^ Plain textstyle.
@ -28,8 +73,15 @@ data Options = Options {
outputStyle :: OutputStyle outputStyle :: OutputStyle
-- | Line separator string. -- | Line separator string.
, lineSeparator :: LineSeparator , 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. -- | @ghc@ program name.
, ghcProgram :: FilePath , ghcProgram :: FilePath
-- | @ghc-pkg@ program name.
, ghcPkgProgram :: FilePath
-- | @cabal@ program name. -- | @cabal@ program name.
, cabalProgram :: FilePath , cabalProgram :: FilePath
-- | GHC command line options set on the @ghc-mod@ command line -- | GHC command line options set on the @ghc-mod@ command line
@ -43,44 +95,114 @@ data Options = Options {
, hlintOpts :: [String] , hlintOpts :: [String]
} deriving (Show) } deriving (Show)
-- | A default 'Options'. -- | A default 'Options'.
defaultOptions :: Options defaultOptions :: Options
defaultOptions = Options { defaultOptions = Options {
outputStyle = PlainStyle outputStyle = PlainStyle
, hlintOpts = [] , lineSeparator = LineSeparator "\0"
, ghcProgram = "ghc" , linePrefix = Nothing
, cabalProgram = "cabal" , logLevel = GmWarning
, ghcUserOptions= [] , ghcProgram = "ghc"
, operators = False , ghcPkgProgram = "ghc-pkg"
, detailed = False , cabalProgram = "cabal"
, qualified = False , ghcUserOptions = []
, lineSeparator = LineSeparator "\0" , operators = False
, detailed = False
, qualified = False
, hlintOpts = []
} }
---------------------------------------------------------------- ----------------------------------------------------------------
data ProjectType = CabalProject | SandboxProject | PlainProject
deriving (Eq, Show)
-- | The environment where this library is used. -- | The environment where this library is used.
data Cradle = Cradle { data Cradle = Cradle {
cradleProjectType:: ProjectType
-- | The directory where this library is executed. -- | The directory where this library is executed.
cradleCurrentDir :: FilePath , cradleCurrentDir :: FilePath
-- | The project root directory. -- | The project root directory.
, cradleRootDir :: FilePath , cradleRootDir :: FilePath
-- | Per-Project temporary directory -- | Per-Project temporary directory
, cradleTempDir :: FilePath , cradleTempDir :: FilePath
-- | The file name of the found cabal file. -- | The file name of the found cabal file.
, cradleCabalFile :: Maybe FilePath , cradleCabalFile :: Maybe FilePath
-- | Package database stack
, cradlePkgDbStack :: [GhcPkgDb]
} deriving (Eq, Show) } 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. -- | 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. -- | A single GHC command line option.
type GHCOption = String type GHCOption = String
-- | An include directory for modules. -- | An include directory for modules.
type IncludeDir = FilePath type IncludeDir = FilePath
@ -89,44 +211,175 @@ type IncludeDir = FilePath
type PackageBaseName = String type PackageBaseName = String
-- | A package version. -- | A package version.
type PackageVersion = String type PackageVersion = String
-- | A package id. -- | A package id.
type PackageId = String type PackageId = String
-- | A package's name, verson and id. -- | A package's name, verson and id.
type Package = (PackageBaseName, PackageVersion, PackageId) type Package = (PackageBaseName, PackageVersion, PackageId)
pkgName :: Package -> PackageBaseName pkgName :: Package -> PackageBaseName
pkgName (n,_,_) = n pkgName (n, _, _) = n
pkgVer :: Package -> PackageVersion pkgVer :: Package -> PackageVersion
pkgVer (_,v,_) = v pkgVer (_, v, _) = v
pkgId :: Package -> PackageId pkgId :: Package -> PackageId
pkgId (_,_,i) = i pkgId (_, _, i) = i
showPkg :: Package -> String showPkg :: Package -> String
showPkg (n,v,_) = intercalate "-" [n,v] showPkg (n, v, _) = intercalate "-" [n, v]
showPkgId :: Package -> String showPkgId :: Package -> String
showPkgId (n,v,i) = intercalate "-" [n,v,i] showPkgId (n, v, i) = intercalate "-" [n, v, i]
-- | Collection of packages
type PkgDb = (M.Map Package PackageConfig)
-- | Haskell expression. -- | Haskell expression.
type Expression = String newtype Expression = Expression { getExpression :: String }
deriving (Show, Eq, Ord)
-- | Module name. -- | Module name.
type ModuleString = String newtype ModuleString = ModuleString { getModuleString :: String }
deriving (Show, Read, Eq, Ord)
-- | A Module data GmLogLevel =
type Module = [String] GmSilent
| GmPanic
| GmException
| GmError
| GmWarning
| GmInfo
| GmDebug
| GmVomit
deriving (Eq, Ord, Enum, Bounded, Show, Read)
-- | Option information for GHC -- | Collection of packages
data CompilerOptions = CompilerOptions { type PkgDb = (Map Package PackageConfig)
ghcOptions :: [GHCOption] -- ^ Command line options
, includeDirs :: [IncludeDir] -- ^ Include directories for modules data GmModuleGraph = GmModuleGraph {
, depPackages :: [Package] -- ^ Dependent package names gmgGraph :: Map ModulePath (Set ModulePath)
} deriving (Eq, Show) } deriving (Eq, Ord, Show, Read, Generic, Typeable)
instance Serialize GmModuleGraph where
put GmModuleGraph {..} = put (mpim, graph)
where
mpim :: Map ModulePath Integer
mpim = Map.fromList $ Map.keys gmgGraph `zip` [0..]
graph :: Map Integer (Set Integer)
graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph
mpToInt :: ModulePath -> Integer
mpToInt mp = fromJust $ Map.lookup mp mpim
get = do
(mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get
let impm = swapMap mpim
intToMp i = fromJust $ Map.lookup i impm
mpGraph :: Map ModulePath (Set ModulePath)
mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph
return $ GmModuleGraph mpGraph
where
swapMap :: (Ord k, Ord v) => Map k v -> Map v k
swapMap = Map.fromList . map (\(x, y) -> (y, x)) . Map.toList
instance Monoid GmModuleGraph where
mempty = GmModuleGraph mempty
mappend (GmModuleGraph a) (GmModuleGraph a') =
GmModuleGraph (Map.unionWith Set.union a a')
data GmComponentType = GMCRaw
| GMCResolved
data GmComponent (t :: GmComponentType) eps = GmComponent {
gmcHomeModuleGraph :: GmModuleGraph
, gmcName :: ChComponentName
, gmcGhcOpts :: [GHCOption]
, gmcGhcPkgOpts :: [GHCOption]
, gmcGhcSrcOpts :: [GHCOption]
, gmcGhcLangOpts :: [GHCOption]
, gmcRawEntrypoints :: ChEntrypoint
, gmcEntrypoints :: eps
, gmcSourceDirs :: [FilePath]
} deriving (Eq, Ord, Show, Read, Generic, Functor)
instance Serialize eps => Serialize (GmComponent t eps)
data ModulePath = ModulePath { mpModule :: ModuleName, mpPath :: FilePath }
deriving (Eq, Ord, Show, Read, Generic, Typeable)
instance Serialize ModulePath
instance Serialize ModuleName where
get = mkModuleName <$> get
put mn = put (moduleNameString mn)
instance Show ModuleName where
show mn = "ModuleName " ++ show (moduleNameString mn)
instance Read ModuleName where
readsPrec d =
readParen
(d > app_prec)
(\r' -> [ (mkModuleName m, t)
| ("ModuleName", s) <- lex r'
, (m, t) <- readsPrec (app_prec + 1) s
])
where
app_prec = 10
data GhcModError
= GMENoMsg
-- ^ Unknown error
| GMEString String
-- ^ Some Error with a message. These are produced mostly by
-- 'fail' calls on GhcModT.
| GMECabalConfigure GhcModError
-- ^ Configuring a cabal project failed.
| GMECabalFlags GhcModError
-- ^ Retrieval of the cabal configuration flags failed.
| GMECabalComponent ChComponentName
-- ^ Cabal component could not be found
| GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)]
-- ^ Could not find a consistent component assignment for modules
| GMEProcess String [String] (Either (String, String, Int) GhcModError)
-- ^ Launching an operating system process failed. Fields in
-- order: command, arguments, (stdout, stderr, exitcode)
| GMENoCabalFile
-- ^ No cabal file found.
| GMETooManyCabalFiles [FilePath]
-- ^ Too many cabal files found.
| GMECabalStateFile GMConfigStateFileError
-- ^ Reading Cabal's state configuration file falied somehow.
deriving (Eq,Show,Typeable)
instance Error GhcModError where
noMsg = GMENoMsg
strMsg = GMEString
instance Exception GhcModError
data GMConfigStateFileError
= GMConfigStateFileNoHeader
| GMConfigStateFileBadHeader
| GMConfigStateFileNoParse
| GMConfigStateFileMissing
-- | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo)
deriving (Eq, Show, Read, Typeable)
deriving instance Generic Version
instance Serialize Version
instance Serialize Programs
instance Serialize ChModuleName
instance Serialize ChComponentName
instance Serialize ChEntrypoint
mkLabel ''GhcModCaches
mkLabel ''GhcModState

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

@ -1,94 +1,159 @@
{-# LANGUAGE CPP #-} -- ghc-mod: Making Haskell development *more* fun
module Language.Haskell.GhcMod.Utils where -- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
import Control.Arrow {-# LANGUAGE CPP #-}
{-# LANGUAGE DoAndIfThenElse #-}
module Language.Haskell.GhcMod.Utils (
module Language.Haskell.GhcMod.Utils
, module Utils
, readProcess
) where
import Control.Applicative
import Data.Char import Data.Char
import Exception
import Language.Haskell.GhcMod.Error import Language.Haskell.GhcMod.Error
import MonadUtils (MonadIO, liftIO) import Language.Haskell.GhcMod.Monad.Types
import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist) import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist,
import System.Exit (ExitCode(..)) getTemporaryDirectory, canonicalizePath)
import System.Process (readProcessWithExitCode)
import System.Directory (getTemporaryDirectory)
import System.FilePath (splitDrive, pathSeparators)
import System.IO.Temp (createTempDirectory)
#ifndef SPEC
import Control.Applicative ((<$>))
import System.Environment import System.Environment
import System.FilePath ((</>),takeDirectory) import System.FilePath (splitDrive, takeDirectory, takeFileName, pathSeparators,
#endif (</>))
import System.IO.Temp (createTempDirectory)
import System.Process (readProcess)
import Text.Printf
import Paths_ghc_mod (getLibexecDir)
import Utils
import Prelude
-- dropWhileEnd is not provided prior to base 4.5.0.0. -- dropWhileEnd is not provided prior to base 4.5.0.0.
dropWhileEnd :: (a -> Bool) -> [a] -> [a] dropWhileEnd :: (a -> Bool) -> [a] -> [a]
dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) [] 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_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a
withDirectory_ dir action = withDirectory_ dir action =
gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory) gbracket
(\_ -> liftIO (setCurrentDirectory dir) >> action) (liftIO getCurrentDirectory)
(liftIO . setCurrentDirectory)
(\_ -> liftIO (setCurrentDirectory dir) >> action)
uniqTempDirName :: FilePath -> FilePath uniqTempDirName :: FilePath -> FilePath
uniqTempDirName dir = ("ghc-mod"++) $ uncurry (++) uniqTempDirName dir =
$ map escapeDriveChar *** map escapePathChar "ghc-mod" ++ map escapeDriveChar drive ++ map escapePathChar path
$ splitDrive dir where
where (drive, path) = splitDrive dir
escapeDriveChar :: Char -> Char
escapeDriveChar c escapeDriveChar c
| isAlphaNum c = c | isAlphaNum c = c
| otherwise = '-' | otherwise = '-'
escapePathChar :: Char -> Char
escapePathChar c escapePathChar c
| c `elem` pathSeparators = '-' | c `elem` pathSeparators = '-'
| otherwise = c | otherwise = c
newTempDir :: FilePath -> IO FilePath newTempDir :: FilePath -> IO FilePath
newTempDir dir = newTempDir dir =
flip createTempDirectory (uniqTempDirName dir) =<< getTemporaryDirectory flip createTempDirectory (uniqTempDirName dir) =<< getTemporaryDirectory
mightExist :: FilePath -> IO (Maybe FilePath) whenM :: Monad m => m Bool -> m () -> m ()
mightExist f = do whenM mb ma = mb >>= flip when ma
exists <- doesFileExist f
return $ if exists then (Just f) else (Nothing)
-- | Returns the path to the currently running ghc-mod executable. With ghc<7.6 -- | Returns the path to the currently running ghc-mod executable. With ghc<7.6
-- this is a guess but >=7.6 uses 'getExecutablePath'. -- this is a guess but >=7.6 uses 'getExecutablePath'.
ghcModExecutable :: IO FilePath ghcModExecutable :: IO FilePath
#ifndef SPEC #ifndef SPEC
ghcModExecutable = do ghcModExecutable = do
dir <- getExecutablePath' dir <- takeDirectory <$> getExecutablePath'
return $ dir </> "ghc-mod" return $ (if dir == "." then "" else dir) </> "ghc-mod"
where
getExecutablePath' :: IO FilePath
# if __GLASGOW_HASKELL__ >= 706
getExecutablePath' = takeDirectory <$> getExecutablePath
# else
getExecutablePath' = return ""
# endif
#else #else
ghcModExecutable = return "dist/build/ghc-mod/ghc-mod" ghcModExecutable = fmap (</> "dist/build/ghc-mod/ghc-mod") getCurrentDirectory
#endif #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 module Language.Haskell.GhcMod.World where
{-(
, World
, getCurrentWorld
, isWorldChanged
) where
-}
import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.PathsAndFiles import Language.Haskell.GhcMod.PathsAndFiles
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad.Types
import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.Utils
import Control.Applicative (pure,(<$>),(<*>)) import Control.Applicative
import Data.Maybe import Data.Maybe
import Data.Traversable (traverse) import Data.Traversable hiding (mapM)
import System.Directory (getModificationTime)
import System.FilePath ((</>)) import System.FilePath ((</>))
import GHC.Paths (libdir) import GHC.Paths (libdir)
import Prelude
#if __GLASGOW_HASKELL__ <= 704
import System.Time (ClockTime)
#else
import Data.Time (UTCTime)
#endif
#if __GLASGOW_HASKELL__ <= 704
type ModTime = ClockTime
#else
type ModTime = UTCTime
#endif
data TimedFile = TimedFile FilePath ModTime deriving (Eq, Show)
instance Ord TimedFile where
compare (TimedFile _ a) (TimedFile _ b) = compare a b
timeFile :: FilePath -> IO TimedFile
timeFile f = TimedFile <$> pure f <*> getModificationTime f
data World = World { data World = World {
worldPackageCaches :: [TimedFile] worldPackageCaches :: [TimedFile]
, worldCabalFile :: Maybe TimedFile , worldCabalFile :: Maybe TimedFile
, worldCabalConfig :: Maybe TimedFile , worldCabalConfig :: Maybe TimedFile
, worldSymbolCache :: Maybe TimedFile
} deriving (Eq, Show) } deriving (Eq, Show)
timedPackageCache :: Cradle -> IO [TimedFile] timedPackageCaches :: IOish m => GhcModT m [TimedFile]
timedPackageCache crdl = do timedPackageCaches = do
fs <- mapM mightExist . map (</> packageCache) fs <- mapM (liftIO . mightExist) . map (</> packageCache)
=<< getPackageCachePaths libdir crdl =<< getPackageCachePaths libdir
timeFile `mapM` catMaybes fs (liftIO . timeFile) `mapM` catMaybes fs
getCurrentWorld :: Cradle -> IO World getCurrentWorld :: IOish m => GhcModT m World
getCurrentWorld crdl = do getCurrentWorld = do
pkgCaches <- timedPackageCache crdl crdl <- cradle
mCabalFile <- timeFile `traverse` cradleCabalFile crdl pkgCaches <- timedPackageCaches
mSetupConfig <- mightExist (setupConfigFile crdl) mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl
mCabalConfig <- timeFile `traverse` mSetupConfig mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl)
mSymbolCache <- liftIO $ timeMaybe (symbolCache crdl)
return World { return World {
worldPackageCaches = pkgCaches worldPackageCaches = pkgCaches
, worldCabalFile = mCabalFile , worldCabalFile = mCabalFile
, worldCabalConfig = mCabalConfig , worldCabalConfig = mCabalConfig
, worldSymbolCache = mSymbolCache
} }
didWorldChange :: World -> Cradle -> IO Bool didWorldChange :: IOish m => World -> GhcModT m Bool
didWorldChange world crdl = do didWorldChange world = do
(world /=) <$> getCurrentWorld crdl (world /=) <$> getCurrentWorld
-- * Neither file exists -> should return False: isYoungerThanSetupConfig :: FilePath -> World -> IO Bool
-- @Nothing < Nothing = False@ isYoungerThanSetupConfig file World {..} = do
-- (since we don't need to @cabal configure@ when no cabal file exists.) tfile <- timeFile file
-- return $ worldCabalConfig < Just tfile
-- * Cabal file doesn't exist (unlikely case) -> should return False
-- @Just cc < Nothing = False@
-- TODO: should we delete dist/setup-config?
--
-- * dist/setup-config doesn't exist yet -> should return True:
-- @Nothing < Just cf = True@
--
-- * Both files exist
-- @Just cc < Just cf = cc < cf = cc `olderThan` cf@
isSetupConfigOutOfDate :: Cradle -> IO Bool
isSetupConfigOutOfDate crdl = do
world <- getCurrentWorld crdl
return $ worldCabalConfig world < worldCabalFile world

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

@ -1,9 +1,9 @@
-- Copyright : Isaac Jones 2003-2004 Copyright Ben Millwood 2012
{- All rights reserved.
All rights reserved.
Redistribution and use in source and binary forms, with or without Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are modification, are permitted provided that the following conditions are met:
met:
* Redistributions of source code must retain the above copyright * Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer. notice, this list of conditions and the following disclaimer.
@ -13,7 +13,7 @@ met:
disclaimer in the documentation and/or other materials provided disclaimer in the documentation and/or other materials provided
with the distribution. 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 contributors may be used to endorse or promote products derived
from this software without specific prior written permission. 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 DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-- | ComponentLocalBuildInfo for Cabal <= 1.16
module Language.Haskell.GhcMod.Cabal16 (
ComponentLocalBuildInfo
, componentPackageDeps
) where
import Distribution.Package (InstalledPackageId, PackageIdentifier)
-- From Cabal <= 1.16
data ComponentLocalBuildInfo = ComponentLocalBuildInfo {
componentPackageDeps :: [(InstalledPackageId, PackageIdentifier)]
}
deriving (Read, Show)

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. 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 ## IRC
If you have any problems, suggestions, comments swing by 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 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 = (:) 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' Couldn't match type `[a -> a]' with `a -> a'
@ -139,7 +139,7 @@ foo xs = foldr _bar id xs
bar = (:) bar = (:)
|< |<
C-c? displays: M-? displays:
>| >|
Found hole `_bar' with type: (a -> a) -> (a -> a) -> a -> a 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")) :underline (:style wave :color "orangered"))
(t (t
:inherit error)) :inherit error))
"Face used for marking error lines." "Face used for error lines."
:group 'ghc) :group 'ghc)
(defface ghc-face-warn (defface ghc-face-warn
@ -28,7 +28,7 @@
:underline (:style wave :color "gold")) :underline (:style wave :color "gold"))
(t (t
:inherit warning)) :inherit warning))
"Face used for marking warning lines." "Face used for warning lines."
:group 'ghc) :group 'ghc)
(defface ghc-face-hole (defface ghc-face-hole
@ -36,7 +36,7 @@
:underline (:style wave :color "purple")) :underline (:style wave :color "purple"))
(t (t
:inherit warning)) :inherit warning))
"Face used for marking hole lines." "Face used for hole lines."
:group 'ghc) :group 'ghc)
(defvar ghc-check-error-fringe (propertize "!" 'display '(left-fringe exclamation-mark))) (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-check-hole-fringe (propertize "_" 'display '(left-fringe horizontal-bar)))
(defvar ghc-display-error nil (defvar ghc-display-error nil
"*An action to display errors/warnings for 'M-n' and 'M-p: "*How to display errors/warnings when using 'M-n' and 'M-p':
nil does not display errors/warnings. nil do not display errors/warnings.
'minibuffer displays errors/warnings in the minibuffer. 'minibuffer display errors/warnings in the minibuffer.
'other-buffer displays errors/warnings in the other buffer. 'other-buffer display errors/warnings in a new buffer.
") ")
(defvar ghc-display-hole 'other-buffer (defvar ghc-display-hole 'other-buffer
"*An action to display hole information for 'C-c C-j' and 'C-c C-h' "*How to display hole information when using 'C-c C-j' and 'C-c C-h'
'minibuffer displays errors/warnings in the minibuffer. 'minibuffer display errors/warnings in the minibuffer.
'other-buffer displays errors/warnings in the other buffer" 'other-buffer display errors/warnings in the a new buffer"
) )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun ghc-check-syntax () (defun ghc-check-syntax ()
(interactive) (interactive)
(ghc-with-process (ghc-check-send) ;; Only check syntax of visible buffers
'ghc-check-callback (when (and (buffer-file-name)
(lambda () (setq mode-line-process " -:-")))) (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) info infos)
(dolist (err errs (nreverse infos)) (dolist (err errs (nreverse infos))
(when (string-match regex err) (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))) (line (string-to-number (match-string 2 err)))
(coln (string-to-number (match-string 3 err))) (coln (string-to-number (match-string 3 err)))
(msg (match-string 4 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. ;; If this is a bottleneck for a large code, let's fix.
(goto-char (point-min)) (goto-char (point-min))
(cond (cond
((and (string= ofile file) hole) ((string= (file-truename ofile) (file-truename file))
(forward-line (1- line)) (if hole
(forward-char (1- coln)) (progn
(setq beg (point)) (forward-line (1- line))
(forward-char (length hole)) (forward-char (1- coln))
(setq end (point))) (setq beg (point))
((string= ofile file) (forward-char (length hole))
(forward-line (1- line)) (setq end (point)))
(while (eq (char-after) 32) (forward-char)) (progn
(setq beg (point)) (forward-line (1- line))
(forward-line) (forward-char (1- coln))
(setq end (1- (point)))) (setq beg (point))
(skip-chars-forward "^[:space:]" (line-end-position))
(setq end (point)))))
(t (t
(setq beg (point)) (setq beg (point))
(forward-line) (forward-line)

2
elisp/ghc-comp.el
View File

@ -127,7 +127,7 @@ unloaded modules are loaded")
(interactive) (interactive)
(if (ghc-should-scroll) (if (ghc-should-scroll)
(ghc-scroll-completion-buffer) (ghc-scroll-completion-buffer)
(ghc-try-complete))) (ghc-try-complete)))
(defun ghc-should-scroll () (defun ghc-should-scroll ()
(let ((window (ghc-completion-window))) (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))) (setq pkg-ver-path (and mod (ghc-resolve-document-path mod)))
(if pkg-ver-path (if pkg-ver-path
(ghc-display-document pkg-ver-path mod haskell-org expr) (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) (ghc-defstruct pkg-ver-path pkg ver path)
@ -93,7 +93,7 @@
(read-from-minibuffer "Module name: " def ghc-input-map)) (read-from-minibuffer "Module name: " def ghc-input-map))
(defun ghc-read-expression (def) (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) (funcall ins-func)
(goto-char (point-min)) (goto-char (point-min))
(if (not fontify) (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) (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 buf
'((display-buffer-reuse-window '((display-buffer-reuse-window
display-buffer-pop-up-window)))))) display-buffer-pop-up-window))))))

4
elisp/ghc-info.el
View File

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

2
elisp/ghc-pkg.el
View File

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

119
elisp/ghc-process.el
View File

@ -10,6 +10,9 @@
(require 'ghc-func) (require 'ghc-func)
(defvar ghc-debug-options nil)
;; (setq ghc-debug-options '("-v9"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar ghc-process-running nil) (defvar ghc-process-running nil)
@ -19,8 +22,11 @@
(defvar-local ghc-process-original-file nil) (defvar-local ghc-process-original-file nil)
(defvar-local ghc-process-callback nil) (defvar-local ghc-process-callback nil)
(defvar-local ghc-process-hook 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"))) (ghc-run-ghc-mod '("root")))
(defun ghc-with-process (cmd callback &optional hook1 hook2) (defun ghc-with-process (cmd callback &optional hook1 hook2)
(unless ghc-process-process-name (let ((root (ghc-get-project-root)))
(setq ghc-process-process-name (ghc-get-project-root))) (unless ghc-process-process-name
(when (and ghc-process-process-name (not ghc-process-running)) (setq ghc-process-process-name root))
(setq ghc-process-running t) (when (and ghc-process-process-name (not ghc-process-running))
(if hook1 (funcall hook1)) (setq ghc-process-running t)
(let* ((cbuf (current-buffer)) (if hook1 (funcall hook1))
(name ghc-process-process-name) (let* ((cbuf (current-buffer))
(buf (get-buffer-create (concat " ghc-modi:" name))) (name ghc-process-process-name)
(file (buffer-file-name)) (buf (get-buffer-create (concat " ghc-mod:" name)))
(cpro (get-process name))) (file (buffer-file-name))
(ghc-with-current-buffer buf (cpro (get-process name)))
(setq ghc-process-original-buffer cbuf) (ghc-with-current-buffer buf
(setq ghc-process-original-file file) (setq ghc-process-original-buffer cbuf)
(setq ghc-process-callback callback) (setq ghc-process-original-file file)
(setq ghc-process-hook hook2) (setq ghc-process-callback callback)
(erase-buffer) (setq ghc-process-hook hook2)
(let ((pro (ghc-get-process cpro name buf))) (setq ghc-process-root root)
(process-send-string pro cmd) (erase-buffer)
(when ghc-debug (let ((pro (ghc-get-process cpro name buf)))
(ghc-with-debug-buffer (process-send-string pro cmd)
(insert (format "%% %s" cmd)))) (when ghc-debug
pro))))) (ghc-with-debug-buffer
(insert (format "%% %s" cmd))))
pro))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -63,37 +71,74 @@
(t cpro))) (t cpro)))
(defun ghc-start-process (name buf) (defun ghc-start-process (name buf)
(let* ((opts (append '("-b" "\n" "-l") (ghc-make-ghc-options))) (let* ((opts (append ghc-debug-options
(pro (apply 'start-file-process name buf ghc-interactive-command opts))) '("-b" "\n" "-l" "--line-prefix=O: ,E: ")
(ghc-make-ghc-options)
'("legacy-interactive")))
(pro (apply 'start-file-process name buf ghc-command opts)))
(set-process-filter pro 'ghc-process-filter) (set-process-filter pro 'ghc-process-filter)
(set-process-sentinel pro 'ghc-process-sentinel) (set-process-sentinel pro 'ghc-process-sentinel)
(set-process-query-on-exit-flag pro nil) (set-process-query-on-exit-flag pro nil)
pro)) pro))
(defun ghc-process-filter (process string) (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)) (if (not (get-buffer pbuf))
(setq ghc-process-running nil) ;; just in case (setq ghc-process-running nil) ;; just in case
(ghc-with-current-buffer (process-buffer process) (ghc-with-current-buffer pbuf
(goto-char (point-max)) (when ghc-debug
(insert string) (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) (forward-line -1)
(cond (cond
((looking-at "^OK$") ((looking-at "^OK$")
(if ghc-process-hook (funcall ghc-process-hook)) (if ghc-process-hook (funcall ghc-process-hook))
(goto-char (point-min)) (goto-char (point-min))
(funcall ghc-process-callback 'ok) (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)) (setq ghc-process-running nil))
((looking-at "^NG ") ((looking-at "^NG ")
(funcall ghc-process-callback '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))))))) (setq ghc-process-running nil)))))))
(defun ghc-process-sentinel (process event) (defun ghc-process-sentinel (process event)

11
elisp/ghc.el
View File

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

212
ghc-mod.cabal
View File

@ -1,73 +1,102 @@
Name: ghc-mod Name: ghc-mod
Version: 5.2.1.2 Version: 5.3.0.0
Author: Kazu Yamamoto <kazu@iij.ad.jp> Author: Kazu Yamamoto <kazu@iij.ad.jp>,
Daniel Gröber <dxld@darkboxed.org> Daniel Gröber <dxld@darkboxed.org>,
Alejandro Serrano <trupill@gmail.com> Alejandro Serrano <trupill@gmail.com>
Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Daniel Gröber <dxld@darkboxed.org>
License: BSD3 License: AGPL-3
License-File: LICENSE License-File: LICENSE
License-Files: COPYING.BSD3 COPYING.AGPL3
Homepage: http://www.mew.org/~kazu/proj/ghc-mod/ Homepage: http://www.mew.org/~kazu/proj/ghc-mod/
Synopsis: Happy Haskell Programming Synopsis: Happy Haskell Programming
Description: The ghc-mod command is a backend command to enrich Description:
Haskell programming on editors including ghc-mod is a backend program to enrich Haskell programming in editors. It
Emacs, Vim, and Sublime. strives to offer most of the features one has come to expect from modern IDEs
The ghc-mod command is based on ghc-mod library in any editor.
which is a wrapper of GHC API.
This package includes the ghc-mod command,
the ghc-mod library, and Emacs front-end
(for historical reasons).
For more information, please see its home page.
Category: Development ghc-mod provides a library for other haskell programs to use as well as a
Cabal-Version: >= 1.10 standalone program for easy editor integration. All of the fundamental
Build-Type: Simple functionality of the frontend program can be accessed through the library
Data-Dir: elisp however many implementation details are hidden and if you want to
Data-Files: Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el significantly extend ghc-mod you should submit these changes upstream instead
ghc-check.el ghc-process.el ghc-command.el ghc-info.el of implementing them on top of the library.
ghc-ins-mod.el ghc-indent.el ghc-pkg.el ghc-rewrite.el
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 Extra-Source-Files: ChangeLog
test/data/*.cabal SetupCompat.hs
test/data/*.hs NotCPP/*.hs
test/data/cabal.sandbox.config.in test/data/annotations/*.hs
test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf
test/data/broken-cabal/*.cabal test/data/broken-cabal/*.cabal
test/data/broken-cabal/cabal.sandbox.config.in test/data/broken-cabal/cabal.sandbox.config.in
test/data/broken-sandbox/*.cabal
test/data/broken-sandbox/cabal.sandbox.config 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/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/*.cabal
test/data/check-test-subdir/src/Check/Test/*.hs test/data/check-test-subdir/src/Check/Test/*.hs
test/data/check-test-subdir/test/*.hs test/data/check-test-subdir/test/*.hs
test/data/check-test-subdir/test/Bar/*.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/cabal.sandbox.config.in
test/data/duplicate-pkgver/duplicate-pkgver.cabal 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-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-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/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf
test/data/pattern-synonyms/*.cabal test/data/foreign-export/*.hs
test/data/pattern-synonyms/*.hs
test/data/ghc-mod-check/*.cabal test/data/ghc-mod-check/*.cabal
test/data/ghc-mod-check/*.hs test/data/ghc-mod-check/*.hs
test/data/ghc-mod-check/Data/*.hs test/data/ghc-mod-check/lib/Data/*.hs
test/data/subdir1/subdir2/dummy test/data/hlint/*.hs
test/data/.cabal-sandbox/packages/00-index.tar test/data/home-module-graph/cpp/*.hs
test/data/home-module-graph/cycle/*.hs
test/data/home-module-graph/errors/*.hs
test/data/home-module-graph/indirect/*.hs
test/data/home-module-graph/indirect-update/*.hs
test/data/import-cycle/*.hs
test/data/non-exported/*.hs
test/data/pattern-synonyms/*.cabal
test/data/pattern-synonyms/*.hs
test/data/quasi-quotes/*.hs
test/data/template-haskell/*.hs
test/data/target/*.hs
test/data/check-missing-warnings/*.hs
test/data/custom-cradle/custom-cradle.cabal
test/data/custom-cradle/ghc-mod.package-db-stack
test/data/custom-cradle/package-db-a/.gitkeep
test/data/custom-cradle/package-db-b/.gitkeep
test/data/custom-cradle/package-db-c/.gitkeep
test/data/cabal-preprocessors/*.cabal
test/data/cabal-preprocessors/*.hs
test/data/cabal-preprocessors/*.hsc
Library Library
Default-Language: Haskell2010 Default-Language: Haskell2010
GHC-Options: -Wall GHC-Options: -Wall -fno-warn-deprecations
Default-Extensions: ConstraintKinds, FlexibleContexts Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns,
ConstraintKinds, FlexibleContexts,
DataKinds, KindSignatures, TypeOperators
Exposed-Modules: Language.Haskell.GhcMod Exposed-Modules: Language.Haskell.GhcMod
Language.Haskell.GhcMod.Internal 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.Browse
Language.Haskell.GhcMod.Cabal16 Language.Haskell.GhcMod.CabalHelper
Language.Haskell.GhcMod.Cabal18 Language.Haskell.GhcMod.Caching
Language.Haskell.GhcMod.Cabal21 Language.Haskell.GhcMod.Caching.Types
Language.Haskell.GhcMod.CabalApi
Language.Haskell.GhcMod.CabalConfig
Language.Haskell.GhcMod.CaseSplit Language.Haskell.GhcMod.CaseSplit
Language.Haskell.GhcMod.Check Language.Haskell.GhcMod.Check
Language.Haskell.GhcMod.Convert Language.Haskell.GhcMod.Convert
@ -79,18 +108,21 @@ Library
Language.Haskell.GhcMod.FillSig Language.Haskell.GhcMod.FillSig
Language.Haskell.GhcMod.Find Language.Haskell.GhcMod.Find
Language.Haskell.GhcMod.Flag Language.Haskell.GhcMod.Flag
Language.Haskell.GhcMod.GHCApi
Language.Haskell.GhcMod.GHCChoice
Language.Haskell.GhcMod.Gap Language.Haskell.GhcMod.Gap
Language.Haskell.GhcMod.GhcPkg Language.Haskell.GhcMod.GhcPkg
Language.Haskell.GhcMod.HomeModuleGraph
Language.Haskell.GhcMod.Info Language.Haskell.GhcMod.Info
Language.Haskell.GhcMod.Lang Language.Haskell.GhcMod.Lang
Language.Haskell.GhcMod.Lint Language.Haskell.GhcMod.Lint
Language.Haskell.GhcMod.Logger Language.Haskell.GhcMod.Logger
Language.Haskell.GhcMod.Logging
Language.Haskell.GhcMod.Modules Language.Haskell.GhcMod.Modules
Language.Haskell.GhcMod.Monad Language.Haskell.GhcMod.Monad
Language.Haskell.GhcMod.Monad.Types
Language.Haskell.GhcMod.Output
Language.Haskell.GhcMod.PathsAndFiles Language.Haskell.GhcMod.PathsAndFiles
Language.Haskell.GhcMod.PkgDoc Language.Haskell.GhcMod.PkgDoc
Language.Haskell.GhcMod.Pretty
Language.Haskell.GhcMod.Read Language.Haskell.GhcMod.Read
Language.Haskell.GhcMod.SrcUtils Language.Haskell.GhcMod.SrcUtils
Language.Haskell.GhcMod.Target Language.Haskell.GhcMod.Target
@ -98,7 +130,10 @@ Library
Language.Haskell.GhcMod.Utils Language.Haskell.GhcMod.Utils
Language.Haskell.GhcMod.World Language.Haskell.GhcMod.World
Build-Depends: base >= 4.0 && < 5 Build-Depends: base >= 4.0 && < 5
, bytestring
, cereal >= 0.4
, containers , containers
, cabal-helper == 0.5.* && >= 0.5.1.0
, deepseq , deepseq
, directory , directory
, filepath , filepath
@ -106,7 +141,6 @@ Library
, ghc-paths , ghc-paths
, ghc-syb-utils , ghc-syb-utils
, hlint >= 1.8.61 , hlint >= 1.8.61
, io-choice
, monad-journal >= 0.4 , monad-journal >= 0.4
, old-time , old-time
, pretty , pretty
@ -117,30 +151,28 @@ Library
, transformers , transformers
, transformers-base , transformers-base
, mtl >= 2.0 , mtl >= 2.0
, monad-control , monad-control >= 1
, split , split
, haskell-src-exts , haskell-src-exts
, text , text
, djinn-ghc >= 0.0.2.2 , djinn-ghc >= 0.0.2.2
if impl(ghc >= 7.8) , fclabels
Build-Depends: Cabal >= 1.18 if impl(ghc < 7.8)
else
Build-Depends: convertible Build-Depends: convertible
, Cabal >= 1.10 && < 1.17 if impl(ghc < 7.5)
if impl(ghc <= 7.4.2)
-- Only used to constrain random to a version that still works with GHC 7.4 -- 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 Executable ghc-mod
Default-Language: Haskell2010 Default-Language: Haskell2010
Main-Is: GHCMod.hs Main-Is: GHCMod.hs
Other-Modules: Paths_ghc_mod Other-Modules: Paths_ghc_mod
GHC-Options: -Wall GHC-Options: -Wall -fno-warn-deprecations
Default-Extensions: ConstraintKinds, FlexibleContexts Default-Extensions: ConstraintKinds, FlexibleContexts
HS-Source-Dirs: src HS-Source-Dirs: src
Build-Depends: base >= 4.0 && < 5 Build-Depends: base >= 4.0 && < 5
, async , async
, data-default
, directory , directory
, filepath , filepath
, pretty , pretty
@ -156,22 +188,17 @@ Executable ghc-modi
Other-Modules: Paths_ghc_mod Other-Modules: Paths_ghc_mod
Misc Misc
Utils Utils
GHC-Options: -Wall -threaded GHC-Options: -Wall -threaded -fno-warn-deprecations
if os(windows) if os(windows)
Cpp-Options: -DWINDOWS Cpp-Options: -DWINDOWS
Default-Extensions: ConstraintKinds, FlexibleContexts Default-Extensions: ConstraintKinds, FlexibleContexts
HS-Source-Dirs: src HS-Source-Dirs: src, .
Build-Depends: base >= 4.0 && < 5 Build-Depends: base >= 4.0 && < 5
, async
, containers
, directory , directory
, filepath , filepath
, old-time
, process , process
, split
, time , time
, ghc , old-time
, ghc-mod
Test-Suite doctest Test-Suite doctest
Type: exitcode-stdio-1.0 Type: exitcode-stdio-1.0
@ -180,20 +207,27 @@ Test-Suite doctest
Ghc-Options: -Wall Ghc-Options: -Wall
Default-Extensions: ConstraintKinds, FlexibleContexts Default-Extensions: ConstraintKinds, FlexibleContexts
Main-Is: doctests.hs Main-Is: doctests.hs
if impl(ghc == 7.4.*)
Buildable: False
Build-Depends: base Build-Depends: base
, doctest >= 0.9.3 , doctest >= 0.9.3
Test-Suite spec Test-Suite spec
Default-Language: Haskell2010 Default-Language: Haskell2010
Default-Extensions: ConstraintKinds, FlexibleContexts Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns,
ConstraintKinds, FlexibleContexts,
DataKinds, KindSignatures, TypeOperators
Main-Is: Main.hs Main-Is: Main.hs
Hs-Source-Dirs: test, . Hs-Source-Dirs: test, .
Ghc-Options: -Wall Ghc-Options: -Wall -fno-warn-deprecations
CPP-Options: -DSPEC=1
Type: exitcode-stdio-1.0 Type: exitcode-stdio-1.0
Other-Modules: BrowseSpec Other-Modules: Paths_ghc_mod
CabalApiSpec
CheckSpec
Dir Dir
Spec
TestUtils
BrowseSpec
CheckSpec
FlagSpec FlagSpec
InfoSpec InfoSpec
LangSpec LangSpec
@ -201,42 +235,14 @@ Test-Suite spec
ListSpec ListSpec
MonadSpec MonadSpec
PathsAndFilesSpec PathsAndFilesSpec
Spec HomeModuleGraphSpec
TestUtils
Build-Depends: base >= 4.0 && < 5 Build-Depends: hspec >= 2.0.0
, containers if impl(ghc == 7.4.*)
, deepseq Build-Depends: executable-path
, directory X-Build-Depends-Like: CLibName
, 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
Source-Repository head Source-Repository head
Type: git 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 #!/bin/sh
set -e
if [ -z "$1" ]; then if [ -z "$1" ]; then
echo "Usage: $0 VERSION" >&2 echo "Usage: $0 VERSION" >&2
exit 1 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 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 \ ( tac ChangeLog; echo "\n$(date '+%Y-%m-%d') v$VERSION" ) | tac \
> ChangeLog.tmp > ChangeLog.tmp
@ -26,6 +35,8 @@ mv ChangeLog.tmp ChangeLog
emacs -q -nw ChangeLog emacs -q -nw ChangeLog
git add ChangeLog elisp/ghc.el ghc-mod.cabal git add ChangeLog
git commit -m "Bump version to $VERSION" git commit -m "ChangeLog"
git tag "v$VERSION" 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 MonadUtils (liftIO)
import Control.Applicative import Control.Applicative
import Control.Monad import Control.Monad
import Control.Exception ( SomeException(..), fromException, Exception
, Handler(..), catches, throw)
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import Data.Version (showVersion) import Data.Version (showVersion)
import Data.Default
import Data.List import Data.List
import Data.List.Split import Data.List.Split
import Data.Maybe
import Data.Char (isSpace) import Data.Char (isSpace)
import Data.Maybe
import Exception
import Language.Haskell.GhcMod import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Internal import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
import Paths_ghc_mod import Paths_ghc_mod
import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..)) import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))
import qualified System.Console.GetOpt as O import qualified System.Console.GetOpt as O
import System.Directory (setCurrentDirectory) import System.FilePath ((</>))
import System.Environment (getArgs,getProgName) import System.Directory (setCurrentDirectory, getAppUserDataDirectory,
removeDirectoryRecursive)
import System.Environment (getArgs)
import System.Exit (exitFailure) import System.Exit (exitFailure)
import System.IO (hPutStrLn, stdout, stderr, hSetEncoding, utf8, hFlush) import System.IO (stdout, hSetEncoding, utf8, hFlush)
import System.IO.Unsafe (unsafePerformIO) import System.Exit (exitSuccess)
import System.FilePath (takeFileName)
import System.Exit (ExitCode, exitSuccess)
import Text.PrettyPrint import Text.PrettyPrint
import Prelude
import Misc import Misc
progVersion :: String -> String
progVersion pf =
"ghc-mod"++pf++" version " ++ showVersion version ++ " compiled by GHC "
++ cProjectVersion ++ "\n"
ghcModVersion :: String
ghcModVersion = progVersion ""
progVersion :: String ghcModiVersion :: String
progVersion = ghcModiVersion = progVersion "i"
progName ++ " version " ++ showVersion version ++ " compiled by GHC "
++ cProjectVersion ++ "\n"
-- TODO: remove (ghc) version prefix!
progName :: String
progName = unsafePerformIO $ takeFileName <$> getProgName
optionUsage :: (String -> String) -> [OptDescr a] -> [String] optionUsage :: (String -> String) -> [OptDescr a] -> [String]
optionUsage indent opts = concatMap optUsage opts optionUsage indent opts = concatMap optUsage opts
@ -65,33 +64,27 @@ optionUsage indent opts = concatMap optUsage opts
ReqArg _ label -> s ++ label ReqArg _ label -> s ++ label
OptArg _ label -> s ++ "["++label++"]" OptArg _ label -> s ++ "["++label++"]"
-- TODO: Generate the stuff below automatically
usage :: String usage :: String
usage = usage =
case progName of "Usage: ghc-mod [OPTIONS...] COMMAND [CMD_ARGS...] \n\
"ghc-modi" -> ghcModiUsage
_ -> ghcModUsage
-- TODO: Generate the stuff below automatically
ghcModUsage :: String
ghcModUsage =
"Usage: ghc-mod [OPTIONS...] COMMAND [OPTIONS...] \n\
\*Global Options (OPTIONS)*\n\ \*Global Options (OPTIONS)*\n\
\ Global options can be specified before and after the command and\n\ \ Global options can be specified before and after the command and\n\
\ interspersed with command specific options\n\ \ interspersed with command specific options\n\
\\n" \\n"
++ (unlines $ indent <$> optionUsage indent globalArgSpec) ++ ++ (unlines $ indent <$> optionUsage indent globalArgSpec) ++
"*Commands*\n\ "*Commands*\n\
\ - version | --version\n\ \ - version\n\
\ Print the version of the program.\n\ \ Print the version of the program.\n\
\\n\ \\n\
\ - help | --help\n\ \ - help\n\
\ Print this help message.\n\ \ Print this help message.\n\
\\n\ \\n\
\ - list [FLAGS...] | modules [FLAGS...]\n\ \ - list [FLAGS...] | modules [FLAGS...]\n\
\ List all visible modules.\n\ \ List all visible modules.\n\
\ Flags:\n\ \ Flags:\n\
\ -d\n\ \ -d\n\
\ Also print the modules' package.\n\ \ Print package modules belong to.\n\
\\n\ \\n\
\ - lang\n\ \ - lang\n\
\ List all known GHC language extensions.\n\ \ List all known GHC language extensions.\n\
@ -183,12 +176,12 @@ ghcModUsage =
\ -l\n\ \ -l\n\
\ Option to be passed to hlint.\n\ \ Option to be passed to hlint.\n\
\\n\ \\n\
\ - root FILE\n\ \ - root\n\
\ Try to find the project directory given FILE. For Cabal\n\ \ Try to find the project directory. For Cabal projects this is the\n\
\ projects this is the directory containing the cabal file, for\n\ \ directory containing the cabal file, for projects that use a cabal\n\
\ projects that use a cabal sandbox but have no cabal file this is the\n\ \ sandbox but have no cabal file this is the directory containing the\n\
\ directory containing the sandbox and otherwise this is the directory\n\ \ cabal.sandbox.config file and otherwise this is the current\n\
\ containing FILE.\n\ \ directory.\n\
\\n\ \\n\
\ - doc MODULE\n\ \ - doc MODULE\n\
\ Try finding the html documentation directory for the given 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\ \ Print debugging information. Please include the output in any bug\n\
\ reports you submit.\n\ \ reports you submit.\n\
\\n\ \\n\
\ - boot\n\ \ - debugComponent [MODULE_OR_FILE...]\n\
\ Internal command used by the emacs frontend.\n" \ Debugging information related to cabal component resolution.\n\
-- "\n\
-- \The following forms are supported so ghc-mod can be invoked by\n\
-- \`cabal repl':\n\
-- \\n\
-- \ ghc-mod --make GHC_OPTIONS\n\
-- \ Pass all options through to the GHC executable.\n\
-- \\n\
-- \ ghc-mod --interactive GHC_OPTIONS [--ghc-mod]\n\
-- \ Start ghci emulation mode. GHC_OPTIONS are passed to the\n\
-- \ GHC API. If `--ghc-mod' is given ghc-mod specific extensions\n\
-- \ are enabled.\n"
where
indent = (" "++)
ghcModiUsage :: String
ghcModiUsage =
"Usage: ghc-modi [OPTIONS...] COMMAND\n\
\*Options*\n"
++ (unlines $ indent <$> optionUsage indent globalArgSpec) ++
"*Commands*\n\
\ - version | --version\n\
\ Print the version of the program.\n\
\\n\ \\n\
\ - help | --help\n\ \ - boot\n\
\ Print this help message.\n" \ Internal command used by the emacs frontend.\n\
\\n\
\ - legacy-interactive\n\
\ ghc-modi compatibility mode.\n"
where where
indent = (" "++) indent = (" "++)
cmdUsage :: String -> String -> String cmdUsage :: String -> String -> String
cmdUsage cmd s = cmdUsage cmd realUsage =
let let
-- Find command head -- 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 -- Take til the end of the current command block
b = flip takeWhile a $ \l -> 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 -- Drop extra newline from the end
c = dropWhileEnd (all isSpace) b c = dropWhileEnd (all isSpace) b
isIndented = (" " `isPrefixOf`) isIndented = (" " `isPrefixOf`)
isNotCmdHead = ( not . (" - " `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
unindent l = l unindent l = l
in unlines $ unindent <$> c in unlines $ unindent <$> c
ghcModStyle :: Style
ghcModStyle = style { lineLength = 80, ribbonsPerLine = 1.2 }
---------------------------------------------------------------- ----------------------------------------------------------------
option :: [Char] -> [String] -> String -> ArgDescr a -> OptDescr a 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 :: String -> (String -> a) -> ArgDescr a
reqArg udsc dsc = ReqArg dsc udsc 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 = globalArgSpec =
[ option "v" ["verbose"] "Be more verbose." $ [ option "v" ["verbose"] "Increase or set log level. (0-7)" $
NoArg $ \o -> o { ghcUserOptions = "-v" : ghcUserOptions o } optArg "LEVEL" $ \ml o -> Right $ o {
logLevel = case ml of
Nothing -> increaseLogLevel (logLevel o)
Just l -> toEnum $ min 7 $ read l
}
, option "s" [] "Be silent, set log level to 0" $
NoArg $ \o -> Right $ o { logLevel = toEnum 0 }
, option "l" ["tolisp"] "Format output as an S-Expression" $ , option "l" ["tolisp"] "Format output as an S-Expression" $
NoArg $ \o -> o { outputStyle = LispStyle } NoArg $ \o -> Right $ o { outputStyle = LispStyle }
, option "b" ["boundary"] "Output line separator"$ , option "b" ["boundary", "line-seperator"] "Output line separator"$
reqArg "SEP" $ \s o -> o { lineSeparator = LineSeparator s } reqArg "SEP" $ \s o -> Right $ o { lineSeparator = LineSeparator s }
, option "" ["line-prefix"] "Output line separator"$
reqArg "OUT,ERR" $ \s o -> let
[out, err] = splitOn "," s
in Right $ o { linePrefix = Just (out, err) }
, option "g" ["ghcOpt"] "Option to be passed to GHC" $ , option "g" ["ghcOpt", "ghc-option"] "Option to be passed to GHC" $
reqArg "OPT" $ \g o -> reqArg "OPT" $ \g o -> Right $
o { ghcUserOptions = g : ghcUserOptions o } o { ghcUserOptions = g : ghcUserOptions o }
, option "" ["with-ghc"] "GHC executable to use" $ , 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" $ , 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 :: [String] -> Either InvalidCommandLine (Options, [String])
parseGlobalArgs argv parseGlobalArgs argv
= case O.getOpt RequireOrder globalArgSpec argv of = case O.getOpt' RequireOrder globalArgSpec argv of
(o,r,[] ) -> Right $ (foldr id defaultOptions o, r) (o,r,u,[]) -> case foldr (=<<) (Right defaultOptions) o of
(_,_,errs) -> Left $ InvalidCommandLine $ Right $ Right o' -> Right (o', u ++ r)
"Parsing command line options failed: " ++ concat errs Left c -> Right (defaultOptions, c)
(_,_,u,e) -> Left $ InvalidCommandLine $ Right $
"Parsing command line options failed: "
++ concat (e ++ map errUnrec u)
where
errUnrec :: String -> String
errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n"
parseCommandArgs :: [OptDescr (Options -> Options)] parseCommandArgs :: [OptDescr (Options -> Either [String] Options)]
-> [String] -> [String]
-> Options -> Options
-> (Options, [String]) -> (Options, [String])
parseCommandArgs spec argv opts parseCommandArgs spec argv opts
= case O.getOpt RequireOrder (globalArgSpec ++ spec) argv of = 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) -> (_,_,errs) ->
fatalError $ "Parsing command options failed: " ++ concat errs fatalError $ "Parsing command options failed: " ++ concat errs
@ -306,121 +323,65 @@ data CmdError = UnknownCommand String
instance Exception CmdError instance Exception CmdError
----------------------------------------------------------------
data InteractiveOptions = InteractiveOptions { data InteractiveOptions = InteractiveOptions {
ghcModExtensions :: Bool ghcModExtensions :: Bool
} }
instance Default InteractiveOptions where handler :: IOish m => GhcModT m a -> GhcModT m a
def = InteractiveOptions False handler = flip gcatches $
[ GHandler $ \(FatalError msg) -> exitError msg
handler :: IO a -> IO a , GHandler $ \(InvalidCommandLine e) -> do
handler = flip catches $
[ Handler $ \(FatalError msg) -> exitError msg
, Handler $ \(InvalidCommandLine e) -> do
case e of case e of
Left cmd -> Left cmd ->
exitError $ (cmdUsage cmd ghcModUsage) ++ "\n" exitError $ "Usage for `"++cmd++"' command:\n\n"
++ progName ++ ": Invalid command line form." ++ (cmdUsage cmd usage) ++ "\n"
Right msg -> exitError $ progName ++ ": " ++ msg ++ "ghc-mod: Invalid command line form."
Right msg -> exitError $ "ghc-mod: " ++ msg
, GHandler $ \(SomeException e) -> exitError $ "ghc-mod: " ++ show e
] ]
main :: IO () main :: IO ()
main = handler $ do main = do
hSetEncoding stdout utf8 hSetEncoding stdout utf8
args <- getArgs 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 case parseGlobalArgs args of
Left e -> case globalCommands args of Left e -> throw e
Just s -> putStr s Right res -> progMain res
Nothing -> throw e
Right res@(_,cmdArgs) ->
case globalCommands cmdArgs of
Just s -> putStr s
Nothing -> progMain res
progMain :: (Options,[String]) -> IO () progMain :: (Options,[String]) -> IO ()
progMain (globalOptions,cmdArgs) = do progMain (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ handler $ do
-- let (ghcArgs, modArgs) = second stripSeperator $ span (/="--") args case globalCommands cmdArgs of
-- _realGhcArgs = filter (/="--ghc-mod") ghcArgs Just s -> gmPutStr s
Nothing -> ghcCommands cmdArgs
-- (globalOptions,_cmdArgs) = parseGlobalArgs modArgs where
hndle action = do
-- stripSeperator ("--":rest) = rest (e, _l) <- action
-- stripSeperator l = l case e of
Right _ ->
case progName of return ()
"ghc-modi" -> do Left ed ->
legacyInteractive globalOptions =<< emptyNewUnGetLine exitError' globalOptions $ renderStyle ghcModStyle (gmeDoc ed)
_
-- | "--numeric-version" `elem` ghcArgs || "--make" `elem` ghcArgs -> do
-- rawSystem (ghcProgram globalOptions) realGhcArgs >>= exitWith
-- | "--interactive" `elem` ghcArgs -> do
-- let interactiveOptions = if "--ghc-mod" `elem` ghcArgs
-- then def { ghcModExtensions = True }
-- else def
-- -- TODO: pass ghcArgs' to ghc API
-- putStrLn "\ninteractive\n"
-- --print realGhcArgs
-- (res, _) <- runGhcModT globalOptions $ undefined
-- case res of
-- Right s -> putStr s
-- Left e -> exitError $ render (gmeDoc e)
| otherwise -> do
(res,_) <- runGhcModT globalOptions $ ghcCommands cmdArgs
case res of
Right s -> putStr s
Left e -> exitError $ render (gmeDoc e)
-- Obtain ghc options by letting ourselfs be executed by
-- @cabal repl@
-- TODO: need to do something about non-cabal projects
-- exe <- ghcModExecutable
-- let cabalArgs = ["repl", "-v0", "--with-ghc="++exe]
-- ++ (("--ghc-option="++) `map` ("--ghc-mod":"--":args))
-- print cabalArgs
-- rawSystem "cabal" cabalArgs >>= exitWith
globalCommands :: [String] -> Maybe String
globalCommands (cmd:_)
| cmd == "help" = Just usage
| cmd == "version" = Just ghcModVersion
globalCommands _ = Nothing
-- ghc-modi -- ghc-modi
legacyInteractive :: Options -> UnGetLine -> IO () legacyInteractive :: IOish m => GhcModT m ()
legacyInteractive opt ref = flip catches handlers $ do legacyInteractive = do
(res,_) <- runGhcModT opt $ do opt <- options
symdbreq <- liftIO $ newSymDbReq opt prepareCabalHelper
world <- liftIO . getCurrentWorld =<< cradle tmpdir <- cradleTempDir <$> cradle
legacyInteractiveLoop symdbreq ref world symdbreq <- liftIO $ newSymDbReq opt tmpdir
world <- getCurrentWorld
legacyInteractiveLoop symdbreq world
case res of bug :: IOish m => String -> GhcModT m ()
Right () -> return ()
Left e -> putStrLn $ notGood $ render (gmeDoc e)
where
handlers = [ Handler $ \Restart -> legacyInteractive opt ref ]
isExitCodeException :: SomeException -> Bool
isExitCodeException e = isJust mExitCode
where
mExitCode :: Maybe ExitCode
mExitCode = fromException e
bug :: String -> IO ()
bug msg = do bug msg = do
putStrLn $ notGood $ "BUG: " ++ msg gmPutStrLn $ notGood $ "BUG: " ++ msg
exitFailure liftIO exitFailure
notGood :: String -> String notGood :: String -> String
notGood msg = "NG " ++ escapeNewlines msg notGood msg = "NG " ++ escapeNewlines msg
@ -431,30 +392,26 @@ escapeNewlines = replace "\n" "\\n" . replace "\\n" "\\\\n"
replace :: String -> String -> String -> String replace :: String -> String -> String -> String
replace needle replacement = intercalate replacement . splitOn needle replace needle replacement = intercalate replacement . splitOn needle
legacyInteractiveLoop :: IOish m legacyInteractiveLoop :: IOish m
=> SymDbReq -> UnGetLine -> World -> GhcModT m () => SymDbReq -> World -> GhcModT m ()
legacyInteractiveLoop symdbreq ref world = do legacyInteractiveLoop symdbreq world = do
liftIO . setCurrentDirectory =<< cradleRootDir <$> cradle liftIO . setCurrentDirectory =<< cradleRootDir <$> cradle
-- blocking -- blocking
cmdArg <- liftIO $ getCommand ref cmdArg <- liftIO $ getLine
-- after blocking, we need to see if the world has changed. -- after blocking, we need to see if the world has changed.
changed <- liftIO . didWorldChange world =<< cradle changed <- didWorldChange world
when changed $ do when changed $ do
liftIO $ ungetCommand ref cmdArg dropSession
throw Restart
liftIO . prepareAutogen =<< cradle
let (cmd':args') = split (keepDelimsR $ condense $ whenElt isSpace) cmdArg let (cmd':args') = split (keepDelimsR $ condense $ whenElt isSpace) cmdArg
arg = concat args' arg = concat args'
cmd = dropWhileEnd isSpace cmd' cmd = dropWhileEnd isSpace cmd'
args = dropWhileEnd isSpace `map` args' args = dropWhileEnd isSpace `map` args'
res <- case dropWhileEnd isSpace cmd of res <- flip gcatches interactiveHandlers $ case dropWhileEnd isSpace cmd of
"check" -> checkSyntaxCmd [arg] "check" -> checkSyntaxCmd [arg]
"lint" -> lintCmd [arg] "lint" -> lintCmd [arg]
"find" -> do "find" -> do
@ -476,22 +433,20 @@ legacyInteractiveLoop symdbreq ref world = do
"" -> liftIO $ exitSuccess "" -> liftIO $ exitSuccess
_ -> fatalError $ "unknown command: `" ++ cmd ++ "'" _ -> fatalError $ "unknown command: `" ++ cmd ++ "'"
liftIO $ putStr res >> putStrLn "OK" >> hFlush stdout gmPutStr res >> gmPutStrLn "OK" >> liftIO (hFlush stdout)
legacyInteractiveLoop symdbreq ref world legacyInteractiveLoop symdbreq world
globalCommands :: [String] -> Maybe String
globalCommands [] = Nothing
globalCommands (cmd:_) = case cmd of
_ | cmd == "help" || cmd == "--help" -> Just usage
_ | cmd == "version" || cmd == "--version" -> Just progVersion
_ -> Nothing
ghcCommands :: IOish m => [String] -> GhcModT m String
ghcCommands [] = fatalError "No command given (try --help)"
ghcCommands (cmd:args) = fn args
where 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 _ | cmd == "list" || cmd == "modules" -> modulesCmd
"lang" -> languagesCmd "lang" -> languagesCmd
"flag" -> flagsCmd "flag" -> flagsCmd
@ -499,6 +454,7 @@ ghcCommands (cmd:args) = fn args
"check" -> checkSyntaxCmd "check" -> checkSyntaxCmd
"expand" -> expandTemplateCmd "expand" -> expandTemplateCmd
"debug" -> debugInfoCmd "debug" -> debugInfoCmd
"debug-component" -> componentInfoCmd
"info" -> infoCmd "info" -> infoCmd
"type" -> typesCmd "type" -> typesCmd
"split" -> splitsCmd "split" -> splitsCmd
@ -511,6 +467,8 @@ ghcCommands (cmd:args) = fn args
"doc" -> pkgDocCmd "doc" -> pkgDocCmd
"dumpsym" -> dumpSymbolCmd "dumpsym" -> dumpSymbolCmd
"boot" -> bootCmd "boot" -> bootCmd
"legacy-interactive" -> legacyInteractiveCmd
-- "nuke-caches" -> nukeCachesCmd
_ -> fatalError $ "unknown command: `" ++ cmd ++ "'" _ -> fatalError $ "unknown command: `" ++ cmd ++ "'"
newtype FatalError = FatalError String deriving (Show, Typeable) newtype FatalError = FatalError String deriving (Show, Typeable)
@ -520,14 +478,18 @@ newtype InvalidCommandLine = InvalidCommandLine (Either String String)
deriving (Show, Typeable) deriving (Show, Typeable)
instance Exception InvalidCommandLine instance Exception InvalidCommandLine
exitError :: String -> IO a exitError :: IOish m => String -> GhcModT m a
exitError msg = hPutStrLn stderr msg >> exitFailure exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure
exitError' :: Options -> String -> IO a
exitError' opts msg =
gmUnsafeErrStrLn opts (dropWhileEnd (=='\n') msg) >> liftIO exitFailure
fatalError :: String -> a fatalError :: String -> a
fatalError s = throw $ FatalError $ progName ++ ": " ++ s fatalError s = throw $ FatalError $ "ghc-mod: " ++ s
withParseCmd :: IOish m withParseCmd :: IOish m
=> [OptDescr (Options -> Options)] => [OptDescr (Options -> Either [String] Options)]
-> ([String] -> GhcModT m a) -> ([String] -> GhcModT m a)
-> [String] -> [String]
-> GhcModT m a -> GhcModT m a
@ -535,25 +497,43 @@ withParseCmd spec action args = do
(opts', rest) <- parseCommandArgs spec args <$> options (opts', rest) <- parseCommandArgs spec args <$> options
withOptions (const opts') $ action rest 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, modulesCmd, languagesCmd, flagsCmd, browseCmd, checkSyntaxCmd, expandTemplateCmd,
debugInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd, refineCmd, autoCmd, debugInfoCmd, componentInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd,
findSymbolCmd, lintCmd, rootInfoCmd, pkgDocCmd, dumpSymbolCmd, bootCmd refineCmd, autoCmd, findSymbolCmd, lintCmd, rootInfoCmd, pkgDocCmd,
dumpSymbolCmd, bootCmd, legacyInteractiveCmd, nukeCachesCmd
:: IOish m => [String] -> GhcModT m String :: IOish m => [String] -> GhcModT m String
modulesCmd = withParseCmd [] $ \[] -> modules modulesCmd = withParseCmd' "modules" s $ \[] -> modules
languagesCmd = withParseCmd [] $ \[] -> languages where s = modulesArgSpec
flagsCmd = withParseCmd [] $ \[] -> flags languagesCmd = withParseCmd' "lang" [] $ \[] -> languages
debugInfoCmd = withParseCmd [] $ \[] -> debugInfo flagsCmd = withParseCmd' "flag" [] $ \[] -> flags
rootInfoCmd = withParseCmd [] $ \[] -> rootInfo debugInfoCmd = withParseCmd' "debug" [] $ \[] -> debugInfo
rootInfoCmd = withParseCmd' "root" [] $ \[] -> rootInfo
componentInfoCmd = withParseCmd' "debugComponent" [] $ \ts -> componentInfo ts
-- internal -- internal
bootCmd = withParseCmd [] $ \[] -> boot bootCmd = withParseCmd' "boot" [] $ \[] -> boot
nukeCachesCmd = withParseCmd' "nuke-caches" [] $ \[] -> nukeCaches >> return ""
dumpSymbolCmd = withParseCmd [] $ \[tmpdir] -> dumpSymbol tmpdir dumpSymbolCmd = withParseCmd' "dump" [] $ \[tmpdir] -> dumpSymbol tmpdir
findSymbolCmd = withParseCmd [] $ \[sym] -> findSymbol sym findSymbolCmd = withParseCmd' "find" [] $ \[sym] -> findSymbol sym
pkgDocCmd = withParseCmd [] $ \[mdl] -> pkgDoc mdl pkgDocCmd = withParseCmd' "doc" [] $ \[mdl] -> pkgDoc mdl
lintCmd = withParseCmd s $ \[file] -> lint file lintCmd = withParseCmd' "lint" s $ \[file] -> lint file
where s = hlintArgSpec where s = hlintArgSpec
browseCmd = withParseCmd s $ \mdls -> concat <$> browse `mapM` mdls browseCmd = withParseCmd s $ \mdls -> concat <$> browse `mapM` mdls
where s = browseArgSpec where s = browseArgSpec
checkSyntaxCmd = withParseCmd [] $ checkAction checkSyntax checkSyntaxCmd = withParseCmd [] $ checkAction checkSyntax
expandTemplateCmd = withParseCmd [] $ checkAction expandTemplate expandTemplateCmd = withParseCmd [] $ checkAction expandTemplate
@ -565,10 +545,20 @@ autoCmd = withParseCmd [] $ locAction "auto" auto
refineCmd = withParseCmd [] $ locAction' "refine" refine refineCmd = withParseCmd [] $ locAction' "refine" refine
infoCmd = withParseCmd [] $ action infoCmd = withParseCmd [] $ action
where action [file,_,expr] = info file expr where action [file,_,expr] = info file $ Expression expr
action [file,expr] = info file expr action [file,expr] = info file $ Expression expr
action _ = throw $ InvalidCommandLine (Left "info") 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 :: ([t] -> a) -> [t] -> a
checkAction _ [] = throw $ InvalidCommandLine (Right "No files given.") checkAction _ [] = throw $ InvalidCommandLine (Right "No files given.")
checkAction action files = action files 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 _ action [file, line,col] = action file (read line) (read col)
locAction cmd _ _ = throw $ InvalidCommandLine (Left cmd) locAction cmd _ _ = throw $ InvalidCommandLine (Left cmd)
locAction' :: String -> (String -> Int -> Int -> String -> a) -> [String] -> a locAction' :: String -> (String -> Int -> Int -> Expression -> a) -> [String] -> a
locAction' _ action [f,_,line,col,expr] = action f (read line) (read col) expr locAction' _ action [f,_,line,col,expr] = action f (read line) (read col) (Expression expr)
locAction' _ action [f, line,col,expr] = action f (read line) (read col) expr locAction' _ action [f, line,col,expr] = action f (read line) (read col) (Expression expr)
locAction' cmd _ _ = throw $ InvalidCommandLine (Left cmd) 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 = hlintArgSpec =
[ option "h" ["hlintOpt"] "Option to be passed to hlint" $ [ 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 = browseArgSpec =
[ option "o" ["operators"] "Also print operators." $ [ 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." $ , option "d" ["detailed"] "Print symbols with accompanying signature." $
NoArg $ \o -> o { detailed = True } NoArg $ \o -> Right $ o { detailed = True }
, option "q" ["qualified"] "Qualify symbols" $ , 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 #-} {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
-- | WARNING -- | WARNING
-- This program in the process of being deprecated, use `ghc-mod --interactive` -- This program is deprecated, use `ghc-mod legacy-interactive` instead.
-- instead.
-- Commands:
-- check <file>
-- find <symbol>
-- info <file> <expr>
-- type <file> <line> <column>
-- lint [hlint options] <file>
-- the format of hlint options is [String] because they may contain
-- spaces and also <file> may contain spaces.
-- boot
-- browse [<package>:]<module>
-- quit
--
-- Session separators:
-- OK -- success
-- NG -- failure
module Main where module Main where
import Config (cProjectVersion) import Control.Applicative
import Control.Applicative ((<$>)) import Control.Monad
import Control.Exception (SomeException(..)) import Control.Exception
import qualified Control.Exception as E import Data.Version
import Control.Monad (when) import Data.Maybe
import CoreMonad (liftIO) import System.IO
import Data.List (intercalate) import System.Exit
import Data.List.Split (splitOn) import System.Process
import Data.Version (showVersion) import System.FilePath
import Language.Haskell.GhcMod import System.Environment
import Language.Haskell.GhcMod.Internal
import Paths_ghc_mod import Paths_ghc_mod
import System.Console.GetOpt
import System.Directory (setCurrentDirectory)
import System.Environment (getArgs)
import System.Exit (ExitCode, exitFailure)
import System.IO (hFlush,stdout)
import Misc
import Utils import Utils
import Prelude
----------------------------------------------------------------
progVersion :: String
progVersion = "ghc-modi version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n"
argspec :: [OptDescr (Options -> Options)]
argspec = [ Option "b" ["boundary"]
(ReqArg (\s opts -> opts { lineSeparator = LineSeparator s }) "sep")
"specify line separator (default is Nul string)"
, Option "l" ["tolisp"]
(NoArg (\opts -> opts { outputStyle = LispStyle }))
"print as a list of Lisp"
, Option "g" []
(ReqArg (\s opts -> opts { ghcUserOptions = s : ghcUserOptions opts }) "flag") "specify a ghc flag"
]
usage :: String
usage = progVersion
++ "Usage:\n"
++ "\t ghc-modi [-l] [-b sep] [-g flag]\n"
++ "\t ghc-modi version\n"
++ "\t ghc-modi help\n"
parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String])
parseArgs spec argv
= case getOpt Permute spec argv of
(o,n,[] ) -> (foldr id defaultOptions o, n)
(_,_,errs) -> E.throw (CmdArg errs)
----------------------------------------------------------------
-- Running two GHC monad threads disables the handling of
-- C-c since installSignalHandlers is called twice, sigh.
main :: IO () main :: IO ()
main = E.handle cmdHandler $ main = do
go =<< parseArgs argspec <$> getArgs hPutStrLn stderr $
where "Warning: ghc-modi is deprecated please use 'ghc-mod legacy-interactive' instead"
cmdHandler (CmdArg _) = putStr $ usageInfo usage argspec
go (_,"help":_) = putStr $ usageInfo usage argspec
go (_,"version":_) = putStr progVersion
go (opt,_) = emptyNewUnGetLine >>= run opt
run :: Options -> UnGetLine -> IO () args <- getArgs
run opt ref = flip E.catches handlers $ do bindir <- getBinDir
cradle0 <- findCradle let installedExe = bindir </> "ghc-mod"
let rootdir = cradleRootDir cradle0 mexe <- mplus <$> mightExist installedExe <*> pathExe
-- c = cradle0 { cradleCurrentDir = rootdir } TODO: ????? case mexe of
setCurrentDirectory rootdir Nothing -> do
prepareAutogen cradle0 hPutStrLn stderr $
-- Asynchronous db loading starts here. "ghc-modi: Could not find '"++installedExe++"', check your installation!"
symdbreq <- newSymDbReq opt exitWith $ ExitFailure 1
(res, _) <- runGhcModT opt $ do
crdl <- cradle
world <- liftIO $ getCurrentWorld crdl
loop symdbreq ref world
case res of
Right () -> return ()
Left (GMECabalConfigure msg) -> do
putStrLn $ notGood $ "cabal configure failed: " ++ show msg
exitFailure
Left e -> bug $ show e
where
-- this is just in case.
-- If an error is caught here, it is a bug of GhcMod library.
handlers = [ E.Handler (\(_ :: ExitCode) -> return ())
, E.Handler (\(_ :: Restart) -> run opt ref)
, E.Handler (\(SomeException e) -> bug $ show e) ]
bug :: String -> IO () Just exe -> do
bug msg = do (_, _, _, h) <-
putStrLn $ notGood $ "BUG: " ++ msg createProcess $ proc exe $ ["legacy-interactive"] ++ args
exitFailure exitWith =<< waitForProcess h
notGood :: String -> String pathExe :: IO (Maybe String)
notGood msg = "NG " ++ escapeNewlines msg pathExe = do
ev <- try $ words <$> readProcess "ghc-mod" ["--version"] ""
let mexe = case ev of
Left (SomeException _) -> Nothing
Right ["ghc-mod", "version", ver
, "compiled", "by", "GHC", _]
| showVersion version == ver -> do
Just "ghc-mod"
Right _ -> Nothing
escapeNewlines :: String -> String when (isNothing mexe) $
escapeNewlines = replace "\n" "\\n" . replace "\\n" "\\\\n" hPutStrLn stderr "ghc-modi: ghc-mod executable on PATH has different version, check your installation!"
return mexe
replace :: String -> String -> String -> String
replace needle replacement = intercalate replacement . splitOn needle
----------------------------------------------------------------
loop :: IOish m => SymDbReq -> UnGetLine -> World -> GhcModT m ()
loop symdbreq ref world = do
-- blocking
cmdArg <- liftIO $ getCommand ref
-- after blocking, we need to see if the world has changed.
crdl <- cradle
changed <- liftIO $ didWorldChange world crdl
when changed $ do
liftIO $ ungetCommand ref cmdArg
E.throw Restart
cradle >>= liftIO . prepareAutogen
let (cmd,arg') = break (== ' ') cmdArg
arg = dropWhile (== ' ') arg'
(ret,ok) <- case cmd of
"check" -> checkStx arg
"find" -> findSym arg symdbreq
"lint" -> lintStx arg
"info" -> showInfo arg
"type" -> showType arg
"split" -> doSplit arg
"sig" -> doSig arg
"refine" -> doRefine arg
"auto" -> doAuto arg
"boot" -> bootIt
"browse" -> browseIt arg
"quit" -> return ("quit", False)
"" -> return ("quit", False)
_ -> return ([], True)
if ok then do
liftIO $ putStr ret
liftIO $ putStrLn "OK"
else do
liftIO $ putStrLn $ notGood ret
liftIO $ hFlush stdout
when ok $ loop symdbreq ref world
----------------------------------------------------------------
checkStx :: IOish m => FilePath -> GhcModT m (String, Bool)
checkStx file = do
eret <- check [file]
case eret of
Right ret -> return (ret, True)
Left ret -> return (ret, True)
----------------------------------------------------------------
findSym :: IOish m => Symbol -> SymDbReq -> GhcModT m (String, Bool)
findSym sym symdbreq = do
db <- getDb symdbreq >>= checkDb symdbreq
ret <- lookupSymbol sym db
return (ret, True)
lintStx :: IOish m => FilePath -> GhcModT m (String, Bool)
lintStx optFile = do
ret <- withOptions changeOpt $ lint file
return (ret, True)
where
(opts,file) = parseLintOptions optFile
hopts = if opts == "" then [] else read opts
changeOpt o = o { hlintOpts = hopts }
-- |
-- >>> parseLintOptions "[\"--ignore=Use camelCase\", \"--ignore=Eta reduce\"] file name"
-- (["--ignore=Use camelCase", "--ignore=Eta reduce"], "file name")
-- >>> parseLintOptions "file name"
-- ([], "file name")
parseLintOptions :: String -> (String, String)
parseLintOptions optFile = case brk (== ']') (dropWhile (/= '[') optFile) of
("","") -> ([], optFile)
(opt',file') -> (opt', dropWhile (== ' ') file')
where
brk _ [] = ([],[])
brk p (x:xs')
| p x = ([x],xs')
| otherwise = let (ys,zs) = brk p xs' in (x:ys,zs)
----------------------------------------------------------------
showInfo :: IOish m => FilePath -> GhcModT m (String, Bool)
showInfo fileArg = do
let [file, expr] = splitN 2 fileArg
ret <- info file expr
return (ret, True)
showType :: IOish m => FilePath -> GhcModT m (String, Bool)
showType fileArg = do
let [file, line, column] = splitN 3 fileArg
ret <- types file (read line) (read column)
return (ret, True)
doSplit :: IOish m => FilePath -> GhcModT m (String, Bool)
doSplit fileArg = do
let [file, line, column] = splitN 3 fileArg
ret <- splits file (read line) (read column)
return (ret, True)
doSig :: IOish m => FilePath -> GhcModT m (String, Bool)
doSig fileArg = do
let [file, line, column] = splitN 3 fileArg
ret <- sig file (read line) (read column)
return (ret, True)
doRefine :: IOish m => FilePath -> GhcModT m (String, Bool)
doRefine fileArg = do
let [file, line, column, expr] = splitN 4 fileArg
ret <- refine file (read line) (read column) expr
return (ret, True)
doAuto :: IOish m => FilePath -> GhcModT m (String, Bool)
doAuto fileArg = do
let [file, line, column] = splitN 3 fileArg
ret <- auto file (read line) (read column)
return (ret, True)
----------------------------------------------------------------
bootIt :: IOish m => GhcModT m (String, Bool)
bootIt = do
ret <- boot
return (ret, True)
browseIt :: IOish m => ModuleString -> GhcModT m (String, Bool)
browseIt mdl = do
let (det,rest') = break (== ' ') mdl
rest = dropWhile (== ' ') rest'
ret <- if det == "-d"
then withOptions setDetailed (browse rest)
else browse mdl
return (ret, True)
where
setDetailed opt = opt { detailed = True }

121
src/Misc.hs
View File

@ -1,75 +1,28 @@
{-# LANGUAGE DeriveDataTypeable, CPP #-} {-# LANGUAGE DeriveDataTypeable, CPP #-}
module Misc ( module Misc (
GHCModiError(..) SymDbReq
, Restart(..)
, UnGetLine
, emptyNewUnGetLine
, ungetCommand
, getCommand
, SymDbReq
, newSymDbReq , newSymDbReq
, getDb , getDb
, checkDb , checkDb
, prepareAutogen
) where ) where
import Control.Applicative ((<$>))
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (Async, async, wait) import Control.Concurrent.Async (Async, async, wait)
import Control.Exception (Exception)
import Control.Monad (unless, when)
import CoreMonad (liftIO) import CoreMonad (liftIO)
import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.List (isPrefixOf) import Prelude
import Data.Maybe (isJust)
import Data.Typeable (Typeable)
import System.Directory (doesDirectoryExist, getDirectoryContents)
import System.IO (openBinaryFile, IOMode(..))
import System.Process
import Language.Haskell.GhcMod import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Internal import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
----------------------------------------------------------------
data GHCModiError = CmdArg [String] deriving (Show, Typeable)
instance Exception GHCModiError
----------------------------------------------------------------
data Restart = Restart deriving (Show, Typeable)
instance Exception Restart
----------------------------------------------------------------
newtype UnGetLine = UnGetLine (IORef (Maybe String))
emptyNewUnGetLine :: IO UnGetLine
emptyNewUnGetLine = UnGetLine <$> newIORef Nothing
ungetCommand :: UnGetLine -> String -> IO ()
ungetCommand (UnGetLine ref) cmd = writeIORef ref (Just cmd)
getCommand :: UnGetLine -> IO String
getCommand (UnGetLine ref) = do
mcmd <- readIORef ref
case mcmd of
Nothing -> getLine
Just cmd -> do
writeIORef ref Nothing
return cmd
---------------------------------------------------------------- ----------------------------------------------------------------
type SymDbReqAction = (Either GhcModError SymbolDb, GhcModLog) type SymDbReqAction = (Either GhcModError SymbolDb, GhcModLog)
data SymDbReq = SymDbReq (IORef (Async SymDbReqAction)) (IO SymDbReqAction) data SymDbReq = SymDbReq (IORef (Async SymDbReqAction)) (IO SymDbReqAction)
newSymDbReq :: Options -> IO SymDbReq newSymDbReq :: Options -> FilePath -> IO SymDbReq
newSymDbReq opt = do newSymDbReq opt dir = do
let act = runGhcModT opt loadSymbolDb let act = runGhcModT opt $ loadSymbolDb dir
req <- async act req <- async act
ref <- newIORef req ref <- newIORef req
return $ SymDbReq ref act return $ SymDbReq ref act
@ -83,7 +36,7 @@ getDb (SymDbReq ref _) = do
checkDb :: IOish m => SymDbReq -> SymbolDb -> GhcModT m SymbolDb checkDb :: IOish m => SymDbReq -> SymbolDb -> GhcModT m SymbolDb
checkDb (SymDbReq ref act) db = do checkDb (SymDbReq ref act) db = do
outdated <- liftIO $ isOutdated db outdated <- isOutdated db
if outdated then do if outdated then do
-- async and wait here is unnecessary because this is essentially -- async and wait here is unnecessary because this is essentially
-- synchronous. But Async can be used a cache. -- synchronous. But Async can be used a cache.
@ -92,63 +45,3 @@ checkDb (SymDbReq ref act) db = do
hoistGhcModT =<< liftIO (wait req) hoistGhcModT =<< liftIO (wait req)
else else
return db 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"] syms `shouldContain` ["Left :: a -> Either a b"]
describe "`browse' in a project directory" $ do describe "`browse' in a project directory" $ do
it "lists symbols defined in a a local module (e.g. `Baz.baz)" $ do it "can list symbols defined in a a local module" $ do
withDirectory_ "test/data" $ do withDirectory_ "test/data/ghc-mod-check/lib" $ do
syms <- runID $ lines <$> browse "Baz" syms <- runD $ lines <$> browse "Data.Foo"
syms `shouldContain` ["baz"] syms `shouldContain` ["foo"]
syms `shouldContain` ["fibonacci"]

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 #-} {-# LANGUAGE CPP #-}
module CheckSpec where module CheckSpec where
import Data.List (isSuffixOf, isInfixOf, isPrefixOf)
import Language.Haskell.GhcMod import Language.Haskell.GhcMod
import System.FilePath
import Data.List
import System.Process
import Test.Hspec import Test.Hspec
import TestUtils import TestUtils
@ -14,38 +15,55 @@ spec = do
describe "checkSyntax" $ do describe "checkSyntax" $ do
it "works even if an executable depends on the library defined in the same cabal file" $ 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 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" 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 it "works even if a module imports another module from a different directory" $ do
withDirectory_ "test/data/check-test-subdir" $ 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`) res `shouldSatisfy` (("test" </> "Foo.hs:3:1:Warning: Top-level binding with no type signature: foo :: [Char]\n") `isSuffixOf`)
it "detects cyclic imports" $ do it "detects cyclic imports" $ do
withDirectory_ "test/data" $ do withDirectory_ "test/data/import-cycle" $ do
res <- runID $ checkSyntax ["Mutual1.hs"] res <- runD $ checkSyntax ["Mutual1.hs"]
res `shouldSatisfy` ("Module imports form a cycle" `isInfixOf`) res `shouldSatisfy` ("Module imports form a cycle" `isInfixOf`)
it "works with modules using QuasiQuotes" $ do it "works with modules using QuasiQuotes" $ do
withDirectory_ "test/data" $ do withDirectory_ "test/data/quasi-quotes" $ do
res <- runID $ checkSyntax ["Baz.hs"] res <- runD $ checkSyntax ["QuasiQuotes.hs"]
res `shouldSatisfy` ("Baz.hs:5:1:Warning:" `isPrefixOf`) res `shouldSatisfy` ("QuasiQuotes.hs:6:1:Warning:" `isInfixOf`)
#if __GLASGOW_HASKELL__ >= 708 #if __GLASGOW_HASKELL__ >= 708
it "works with modules using PatternSynonyms" $ do it "works with modules using PatternSynonyms" $ do
withDirectory_ "test/data/pattern-synonyms" $ 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`) res `shouldSatisfy` ("B.hs:6:9:Warning:" `isPrefixOf`)
#endif #endif
it "works with foreign exports" $ do it "works with foreign exports" $ do
withDirectory_ "test/data" $ do withDirectory_ "test/data/foreign-export" $ do
res <- runID $ checkSyntax ["ForeignExport.hs"] res <- runD $ checkSyntax ["ForeignExport.hs"]
res `shouldBe` "" res `shouldBe` ""
context "when no errors are found" $ do context "when no errors are found" $ do
it "doesn't output an empty line" $ do it "doesn't output an empty line" $ do
withDirectory_ "test/data/ghc-mod-check/Data" $ do withDirectory_ "test/data/ghc-mod-check/lib/Data" $ do
res <- runID $ checkSyntax ["Foo.hs"] res <- runD $ checkSyntax ["Foo.hs"]
res `shouldBe` "" 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 Data.List (isSuffixOf)
import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.Cradle
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import System.Directory (canonicalizePath,getCurrentDirectory) import System.Directory (canonicalizePath)
import System.FilePath ((</>), pathSeparator) import System.FilePath (pathSeparator)
import Test.Hspec import Test.Hspec
import Dir import Dir
spec :: Spec clean_ :: IO Cradle -> IO Cradle
spec = do clean_ f = do
describe "findCradle" $ do crdl <- f
it "returns the current directory" $ do cleanupCradle crdl
withDirectory_ "/" $ do return crdl
curDir <- stripLastDot <$> canonicalizePath "/"
res <- findCradle
cradleCurrentDir res `shouldBe` curDir
cradleRootDir res `shouldBe` curDir
cradleCabalFile res `shouldBe` Nothing
cradlePkgDbStack res `shouldBe` [GlobalDb,UserDb]
it "finds a cabal file and a sandbox" $ do
cwd <- getCurrentDirectory
withDirectory "test/data/subdir1/subdir2" $ \dir -> do
res <- relativeCradle dir <$> findCradle
cradleCurrentDir res `shouldBe` "test" </> "data" </> "subdir1" </> "subdir2"
cradleRootDir res `shouldBe` "test" </> "data"
cradleCabalFile res `shouldBe` Just ("test" </> "data" </> "cabalapi.cabal")
cradlePkgDbStack res `shouldBe` [GlobalDb, PackageDb (cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d")]
it "works even if a sandbox config file is broken" $ do
withDirectory "test/data/broken-sandbox" $ \dir -> do
res <- relativeCradle dir <$> findCradle
cradleCurrentDir res `shouldBe` "test" </> "data" </> "broken-sandbox"
cradleRootDir res `shouldBe` "test" </> "data" </> "broken-sandbox"
cradleCabalFile res `shouldBe` Just ("test" </> "data" </> "broken-sandbox" </> "dummy.cabal")
cradlePkgDbStack res `shouldBe` [GlobalDb, UserDb]
relativeCradle :: FilePath -> Cradle -> Cradle relativeCradle :: FilePath -> Cradle -> Cradle
relativeCradle dir cradle = cradle { relativeCradle dir crdl = crdl {
cradleCurrentDir = toRelativeDir dir $ cradleCurrentDir cradle cradleCurrentDir = toRelativeDir dir $ cradleCurrentDir crdl
, cradleRootDir = toRelativeDir dir $ cradleRootDir cradle , cradleRootDir = toRelativeDir dir $ cradleRootDir crdl
, cradleCabalFile = toRelativeDir dir <$> cradleCabalFile cradle , cradleCabalFile = toRelativeDir dir <$> cradleCabalFile crdl
} }
-- Work around GHC 7.2.2 where `canonicalizePath "/"` returns "/.". -- Work around GHC 7.2.2 where `canonicalizePath "/"` returns "/.".
@ -51,3 +28,38 @@ stripLastDot :: FilePath -> FilePath
stripLastDot path stripLastDot path
| (pathSeparator:'.':"") `isSuffixOf` path = init path | (pathSeparator:'.':"") `isSuffixOf` path = init path
| otherwise = 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 Control.Exception as E
import Data.List (isPrefixOf) import Data.List (isPrefixOf)
import System.Directory import System.Directory
import System.FilePath (addTrailingPathSeparator) import System.FilePath (addTrailingPathSeparator,(</>))
withDirectory_ :: FilePath -> IO a -> IO a withDirectory_ :: FilePath -> IO a -> IO a
withDirectory_ dir action = bracket getCurrentDirectory withDirectory_ dir action = bracket getCurrentDirectory

5
test/FindSpec.hs
View File

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

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

6
test/LintSpec.hs
View File

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

25
test/Main.hs
View File

@ -4,6 +4,7 @@ import Dir
import Control.Exception as E import Control.Exception as E
import Control.Monad (void) import Control.Monad (void)
import Data.List
import Language.Haskell.GhcMod (debugInfo) import Language.Haskell.GhcMod (debugInfo)
import System.Process import System.Process
import Test.Hspec import Test.Hspec
@ -11,22 +12,38 @@ import TestUtils
main :: IO () main :: IO ()
main = do 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/duplicate-pkgver/"
, "test/data/broken-cabal/" , "test/data/broken-cabal/"
] ]
genSandboxCfg dir = withDirectory dir $ \cwdir -> do genSandboxCfg dir = withDirectory dir $ \cwdir -> do
system ("sed 's|@CWD@|" ++ cwdir ++ "|g' cabal.sandbox.config.in > cabal.sandbox.config") system ("sed 's|@CWD@|" ++ cwdir ++ "|g' cabal.sandbox.config.in > cabal.sandbox.config")
pkgDirs = 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/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"] , "test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"]
genGhcPkgCache dir = system $ "ghc-pkg recache --force -f" ++ dir genGhcPkgCache dir = system $ "ghc-pkg recache --force -f" ++ dir
genSandboxCfg `mapM_` sandboxes genSandboxCfg `mapM_` sandboxes
genGhcPkgCache `mapM_` pkgDirs 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" void $ system "cabal --version"
putStrLn $ "ghc-mod was built with Cabal version " ++ VERSION_Cabal
void $ system "ghc --version" void $ system "ghc --version"
(putStrLn =<< runD debugInfo) (putStrLn =<< runD debugInfo)

24
test/MonadSpec.hs
View File

@ -1,39 +1,17 @@
{-# LANGUAGE ScopedTypeVariables #-}
module MonadSpec where module MonadSpec where
import Test.Hspec import Test.Hspec
import Dir
import TestUtils import TestUtils
import Control.Applicative
import Control.Exception
import Control.Monad.Error.Class import Control.Monad.Error.Class
spec :: Spec spec :: Spec
spec = do spec = do
describe "When using GhcModT in a do block" $ 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 it "a pattern match failure causes a call to `fail` on ErrorT in the monad stack" $ do
(a, _) (a, _h)
<- runGhcModT defaultOptions $ <- runGhcModT defaultOptions $
do do
Just _ <- return Nothing Just _ <- return Nothing
return "hello" return "hello"
`catchError` (const $ fail "oh noes") `catchError` (const $ fail "oh noes")
a `shouldBe` (Left $ GMEString "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 module PathsAndFilesSpec where
import Language.Haskell.GhcMod.PathsAndFiles 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.Directory
import System.Environment import System.FilePath
import System.FilePath ((</>))
import Test.Hspec import Test.Hspec
import TestUtils
spec :: Spec spec :: Spec
spec = do spec = do
describe "getSandboxDb" $ 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 it "can parse a config file and extract the sandbox package-db" $ do
cwd <- getCurrentDirectory cwd <- getCurrentDirectory
pkgDb <- getSandboxDb "test/data/" Just db <- getSandboxDb "test/data/cabal-project"
pkgDb `shouldBe` Just (cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d") db `shouldSatisfy` isPkgDbAt (cwd </> "test/data/cabal-project/.cabal-sandbox")
it "returns Nothing if the sandbox config file is broken" $ do it "returns Nothing if the sandbox config file is broken" $ do
getSandboxDb "test/data/broken-sandbox" `shouldReturn` Nothing 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 describe "findCabalFile" $ do
it "works" $ 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 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 ( module TestUtils (
run run
, runD , runD
, runD' , runD'
, runI , runE
, runID , runNullLog
, runIsolatedGhcMod
, isolateCradle
, shouldReturnError , shouldReturnError
, isPkgDbAt
, isPkgConfDAt
, module Language.Haskell.GhcMod.Monad , module Language.Haskell.GhcMod.Monad
, module Language.Haskell.GhcMod.Types , module Language.Haskell.GhcMod.Types
) where ) where
import Language.Haskell.GhcMod.Logging
import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Cradle
import Language.Haskell.GhcMod.Types 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 import Test.Hspec
isolateCradle :: IOish m => GhcModT m a -> GhcModT m a import Exception
isolateCradle action =
local modifyEnv $ action testLogLevel :: GmLogLevel
where testLogLevel = GmDebug
modifyEnv e = e { gmCradle = (gmCradle e) { cradlePkgDbStack = [GlobalDb] } }
extract :: Show e => IO (Either e a, w) -> IO a extract :: Show e => IO (Either e a, w) -> IO a
extract action = do extract action = do
@ -29,28 +39,46 @@ extract action = do
Right a -> return a Right a -> return a
Left e -> error $ show e Left e -> error $ show e
runIsolatedGhcMod :: Options -> GhcModT IO a -> IO a withSpecCradle :: IOish m => FilePath -> (Cradle -> m a) -> m a
runIsolatedGhcMod opt action = do withSpecCradle cradledir f =
extract $ runGhcModT opt $ isolateCradle action gbracket (liftIO $ findSpecCradle cradledir) (liftIO . cleanupCradle) f
-- | Run GhcMod in isolated cradle with default options withGhcModEnvSpec :: IOish m => FilePath -> Options -> (GhcModEnv -> m a) -> m a
runID :: GhcModT IO a -> IO a withGhcModEnvSpec dir opt f = withSpecCradle dir $ withGhcModEnv' opt f
runID = runIsolatedGhcMod defaultOptions
-- | Run GhcMod in isolated cradle runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog)
runI :: Options -> GhcModT IO a -> IO a runGhcModTSpec opt action = do
runI = runIsolatedGhcMod dir <- getCurrentDirectory
runGhcModTSpec' dir opt action
runGhcModTSpec' :: IOish m
=> FilePath -> Options -> GhcModT m b -> m (Either GhcModError b, GhcModLog)
runGhcModTSpec' dir opt action = liftIO (canonicalizePath dir) >>= \dir' ->
withGhcModEnvSpec dir' opt $ \env -> do
first (fst <$>) <$> runGhcModT'' env defaultGhcModState
(gmSetLogLevel (logLevel opt) >> action)
-- | Run GhcMod -- | Run GhcMod
run :: Options -> GhcModT IO a -> IO a 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 -- | Run GhcMod with default options
runD :: GhcModT IO a -> IO a runD :: GhcModT IO a -> IO a
runD = extract . runGhcModT defaultOptions runD =
extract . runGhcModTSpec defaultOptions { logLevel = testLogLevel }
runD' :: GhcModT IO a -> IO (Either GhcModError a, GhcModLog) runD' :: FilePath -> GhcModT IO a -> IO a
runD' = runGhcModT defaultOptions runD' dir =
extract . runGhcModTSpec' dir defaultOptions { logLevel = testLogLevel }
runE :: ErrorT e IO a -> IO (Either e a)
runE = runErrorT
runNullLog :: MonadIO m => JournalT GhcModLog m a -> m a
runNullLog action = do
(a,w) <- runJournalT action
liftIO $ print w
return a
shouldReturnError :: Show a shouldReturnError :: Show a
=> IO (Either GhcModError a, GhcModLog) => IO (Either GhcModError a, GhcModLog)
@ -61,3 +89,21 @@ shouldReturnError action = do
where where
isLeft (Left _) = True isLeft (Left _) = True
isLeft _ = False 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 default: False
library library
build-depends: base == 4.* build-depends: base
if flag(test-flag) if flag(test-flag)
build-depends: Cabal >= 1.10 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