Merge branch 'master' into release
This commit is contained in:
commit
eb0413c407
6
.gitignore
vendored
6
.gitignore
vendored
@ -7,8 +7,14 @@ package.cache
|
||||
cabal.sandbox.config
|
||||
# Mac OS generates
|
||||
# .DS_Store
|
||||
*.o
|
||||
*.dyn_o
|
||||
*.hi
|
||||
*.dyn_hi
|
||||
|
||||
# Where do these files come from? They're not readable.
|
||||
# For instance, .#Help.page
|
||||
# .#*
|
||||
cabal-dev
|
||||
/TAGS
|
||||
/tags
|
||||
|
28
.travis.yml
28
.travis.yml
@ -4,11 +4,36 @@ ghc:
|
||||
- 7.6
|
||||
- 7.8
|
||||
|
||||
sudo: false
|
||||
|
||||
addons:
|
||||
apt:
|
||||
packages:
|
||||
- zlib1g-dev
|
||||
|
||||
cache:
|
||||
apt: true
|
||||
directories:
|
||||
- ~/.cabal
|
||||
- ~/.ghc
|
||||
|
||||
before_cache:
|
||||
- rm -f $HOME/.cabal/logs $HOME/.cabal/packages/*/build-reports.log
|
||||
|
||||
install:
|
||||
- cabal update
|
||||
- cabal install happy --constraint 'transformers <= 0.3.0.0'
|
||||
# - ( $CABAL122 && cabal install cabal-install --constraint "Cabal >= 1.22" && ghc-pkg unregister Cabal ) || true
|
||||
- echo $PATH
|
||||
- which cabal
|
||||
- if [ -n "$(cabal --version | grep 'Cabal library' | awk '{ print $3 }' | tail -n1 | sed -n '/^1.18/p')" ]; then cabal install cabal-install --constraint "Cabal == 1.18.* && > 1.18.0"; fi
|
||||
- cabal install happy
|
||||
- happy --version
|
||||
# - ls -lR ~/.ghc
|
||||
# - ls -lR ~/.cabal
|
||||
- cabal install -j --only-dependencies --enable-tests
|
||||
- git clone --depth=1 https://github.com/DanielG/cabal-helper.git
|
||||
- cabal install cabal-helper/
|
||||
|
||||
|
||||
script:
|
||||
- touch ChangeLog # Create ChangeLog if we're not on the release branch
|
||||
@ -21,6 +46,7 @@ script:
|
||||
- if [ -n "$(ghc --version | awk '{ print $8 }' | sed -n '/^7.8/p')" ]; then export WERROR="--ghc-option=-Werror"; fi
|
||||
- cabal configure --enable-tests $WERROR
|
||||
- cabal build
|
||||
- export ghc_mod_datadir=$PWD
|
||||
- cabal test
|
||||
|
||||
matrix:
|
||||
|
661
COPYING.AGPL3
Normal file
661
COPYING.AGPL3
Normal 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
29
COPYING.BSD3
Normal 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
33
LICENSE
@ -1,29 +1,6 @@
|
||||
Copyright (c) 2009, IIJ Innovation Institute Inc.
|
||||
All rights reserved.
|
||||
ghc-mod was originally licensed under the BSD3 but the primary license has been
|
||||
changed to the AGPL3, files originally contributed under the BSD3 license remain
|
||||
under this license and can generally be identified by the lack of a GPL header.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions
|
||||
are met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
* Redistributions in binary form must reproduce the above copyright
|
||||
notice, this list of conditions and the following disclaimer in
|
||||
the documentation and/or other materials provided with the
|
||||
distribution.
|
||||
* Neither the name of the copyright holders nor the names of its
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
|
||||
FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
|
||||
COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
|
||||
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
|
||||
BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
|
||||
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
|
||||
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
|
||||
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
|
||||
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
||||
POSSIBILITY OF SUCH DAMAGE.
|
||||
See the files COPYING.BSD3 and COPYING.AGPL3 in the source distribution for
|
||||
copies of the two licenses.
|
||||
|
@ -3,15 +3,22 @@
|
||||
module Language.Haskell.GhcMod (
|
||||
-- * Cradle
|
||||
Cradle(..)
|
||||
, ProjectType(..)
|
||||
, findCradle
|
||||
-- * Options
|
||||
, Options(..)
|
||||
, LineSeparator(..)
|
||||
, OutputStyle(..)
|
||||
, defaultOptions
|
||||
-- * Logging
|
||||
, GmLogLevel
|
||||
, increaseLogLevel
|
||||
, decreaseLogLevel
|
||||
, gmSetLogLevel
|
||||
, gmLog
|
||||
-- * Types
|
||||
, ModuleString
|
||||
, Expression
|
||||
, Expression(..)
|
||||
, GhcPkgDb
|
||||
, Symbol
|
||||
, SymbolDb
|
||||
@ -22,12 +29,14 @@ module Language.Haskell.GhcMod (
|
||||
-- * Monad utilities
|
||||
, runGhcModT
|
||||
, withOptions
|
||||
, dropSession
|
||||
-- * 'GhcMod' utilities
|
||||
, boot
|
||||
, browse
|
||||
, check
|
||||
, checkSyntax
|
||||
, debugInfo
|
||||
, componentInfo
|
||||
, expandTemplate
|
||||
, info
|
||||
, lint
|
||||
@ -47,6 +56,13 @@ module Language.Haskell.GhcMod (
|
||||
-- * SymbolDb
|
||||
, loadSymbolDb
|
||||
, isOutdated
|
||||
-- * Output
|
||||
, gmPutStr
|
||||
, gmErrStr
|
||||
, gmPutStrLn
|
||||
, gmErrStrLn
|
||||
, gmUnsafePutStrLn
|
||||
, gmUnsafeErrStrLn
|
||||
) where
|
||||
|
||||
import Language.Haskell.GhcMod.Boot
|
||||
@ -61,7 +77,10 @@ import Language.Haskell.GhcMod.Flag
|
||||
import Language.Haskell.GhcMod.Info
|
||||
import Language.Haskell.GhcMod.Lang
|
||||
import Language.Haskell.GhcMod.Lint
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.Logging
|
||||
import Language.Haskell.GhcMod.Modules
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.PkgDoc
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Target
|
||||
import Language.Haskell.GhcMod.Output
|
||||
|
@ -1,6 +1,7 @@
|
||||
module Language.Haskell.GhcMod.Boot where
|
||||
|
||||
import Control.Applicative
|
||||
import Prelude
|
||||
import Language.Haskell.GhcMod.Browse
|
||||
import Language.Haskell.GhcMod.Flag
|
||||
import Language.Haskell.GhcMod.Lang
|
||||
@ -9,8 +10,9 @@ import Language.Haskell.GhcMod.Modules
|
||||
|
||||
-- | Printing necessary information for front-end booting.
|
||||
boot :: IOish m => GhcModT m String
|
||||
boot = concat <$> sequence [modules, languages, flags,
|
||||
concat <$> mapM browse preBrowsedModules]
|
||||
boot = concat <$> sequence ms
|
||||
where
|
||||
ms = [modules, languages, flags, concat <$> mapM browse preBrowsedModules]
|
||||
|
||||
preBrowsedModules :: [String]
|
||||
preBrowsedModules = [
|
||||
|
@ -2,54 +2,57 @@ module Language.Haskell.GhcMod.Browse (
|
||||
browse
|
||||
) where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Applicative
|
||||
import Control.Exception (SomeException(..))
|
||||
import Data.Char (isAlpha)
|
||||
import Data.List (sort)
|
||||
import Data.Maybe (catMaybes)
|
||||
import Exception (ghandle)
|
||||
import FastString (mkFastString)
|
||||
import GHC (GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon)
|
||||
import Data.Char
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import FastString
|
||||
import GHC
|
||||
import qualified GHC as G
|
||||
import Language.Haskell.GhcMod.Convert
|
||||
import Language.Haskell.GhcMod.Doc (showPage, styleUnqualified)
|
||||
import Language.Haskell.GhcMod.Gap
|
||||
import Language.Haskell.GhcMod.Monad (GhcModT, options)
|
||||
import Language.Haskell.GhcMod.Target (setTargetFiles)
|
||||
import Language.Haskell.GhcMod.Gap as Gap
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Name (getOccString)
|
||||
import Outputable (ppr, Outputable)
|
||||
import Outputable
|
||||
import TyCon (isAlgTyCon)
|
||||
import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy)
|
||||
import Exception (ExceptionMonad, ghandle)
|
||||
import Prelude
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Getting functions, classes, etc from a module.
|
||||
-- If 'detailed' is 'True', their types are also obtained.
|
||||
-- If 'operators' is 'True', operators are also returned.
|
||||
browse :: IOish m
|
||||
=> ModuleString -- ^ A module name. (e.g. \"Data.List\")
|
||||
browse :: forall m. IOish m
|
||||
=> String -- ^ A module name. (e.g. \"Data.List\", "base:Prelude")
|
||||
-> GhcModT m String
|
||||
browse pkgmdl = convert' . sort =<< (listExports =<< getModule)
|
||||
browse pkgmdl = do
|
||||
convert' . sort =<< go
|
||||
where
|
||||
-- TODO: Add API to Gm.Target to check if module is home module without
|
||||
-- bringing up a GHC session as well then this can be made a lot cleaner
|
||||
go = ghandle (\(SomeException _) -> return []) $ do
|
||||
goPkgModule `G.gcatch` (\(SomeException _) -> goHomeModule)
|
||||
|
||||
goPkgModule = do
|
||||
opt <- options
|
||||
runGmPkgGhc $
|
||||
processExports opt =<< tryModuleInfo =<< G.findModule mdlname mpkgid
|
||||
|
||||
goHomeModule = runGmlT [Right mdlname] $ do
|
||||
opt <- options
|
||||
processExports opt =<< tryModuleInfo =<< G.findModule mdlname Nothing
|
||||
|
||||
tryModuleInfo m = fromJust <$> G.getModuleInfo m
|
||||
|
||||
(mpkg, mdl) = splitPkgMdl pkgmdl
|
||||
mdlname = G.mkModuleName mdl
|
||||
mpkgid = mkFastString <$> mpkg
|
||||
listExports Nothing = return []
|
||||
listExports (Just mdinfo) = processExports mdinfo
|
||||
-- findModule works only for package modules, moreover,
|
||||
-- you cannot load a package module. On the other hand,
|
||||
-- to browse a local module you need to load it first.
|
||||
-- If CmdLineError is signalled, we assume the user
|
||||
-- tried browsing a local module.
|
||||
getModule = browsePackageModule `G.gcatch` fallback `G.gcatch` handler
|
||||
browsePackageModule = G.findModule mdlname mpkgid >>= G.getModuleInfo
|
||||
browseLocalModule = ghandle handler $ do
|
||||
setTargetFiles [mdl]
|
||||
G.findModule mdlname Nothing >>= G.getModuleInfo
|
||||
fallback (CmdLineError _) = browseLocalModule
|
||||
fallback _ = return Nothing
|
||||
handler (SomeException _) = return Nothing
|
||||
|
||||
-- |
|
||||
--
|
||||
-- >>> splitPkgMdl "base:Prelude"
|
||||
@ -57,7 +60,8 @@ browse pkgmdl = convert' . sort =<< (listExports =<< getModule)
|
||||
-- >>> splitPkgMdl "Prelude"
|
||||
-- (Nothing,"Prelude")
|
||||
splitPkgMdl :: String -> (Maybe String,String)
|
||||
splitPkgMdl pkgmdl = case break (==':') pkgmdl of
|
||||
splitPkgMdl pkgmdl =
|
||||
case break (==':') pkgmdl of
|
||||
(mdl, "") -> (Nothing, mdl)
|
||||
(pkg, _:mdl) -> (Just pkg, mdl)
|
||||
|
||||
@ -71,22 +75,23 @@ isNotOp :: String -> Bool
|
||||
isNotOp (h:_) = isAlpha h || (h == '_')
|
||||
isNotOp _ = error "isNotOp"
|
||||
|
||||
processExports :: IOish m => ModuleInfo -> GhcModT m [String]
|
||||
processExports minfo = do
|
||||
opt <- options
|
||||
processExports :: (G.GhcMonad m, MonadIO m, ExceptionMonad m)
|
||||
=> Options -> ModuleInfo -> m [String]
|
||||
processExports opt minfo = do
|
||||
let
|
||||
removeOps
|
||||
| operators opt = id
|
||||
| otherwise = filter (isNotOp . getOccString)
|
||||
mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo
|
||||
|
||||
showExport :: IOish m => Options -> ModuleInfo -> Name -> GhcModT m String
|
||||
showExport :: forall m. (G.GhcMonad m, MonadIO m, ExceptionMonad m)
|
||||
=> Options -> ModuleInfo -> Name -> m String
|
||||
showExport opt minfo e = do
|
||||
mtype' <- mtype
|
||||
return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype']
|
||||
where
|
||||
mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` qualified opt
|
||||
mtype :: IOish m => GhcModT m (Maybe String)
|
||||
mtype :: m (Maybe String)
|
||||
mtype
|
||||
| detailed opt = do
|
||||
tyInfo <- G.modInfoLookupName minfo e
|
||||
@ -101,8 +106,9 @@ showExport opt minfo e = do
|
||||
| null nm = error "formatOp"
|
||||
| isNotOp nm = nm
|
||||
| otherwise = "(" ++ nm ++ ")"
|
||||
inOtherModule :: IOish m => Name -> GhcModT m (Maybe TyThing)
|
||||
inOtherModule nm = G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm
|
||||
inOtherModule :: Name -> m (Maybe TyThing)
|
||||
inOtherModule nm = do
|
||||
G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm
|
||||
justIf :: a -> Bool -> Maybe a
|
||||
justIf x True = Just x
|
||||
justIf _ False = Nothing
|
||||
@ -127,7 +133,7 @@ tyType typ
|
||||
&& not (G.isClassTyCon typ) = Just "data"
|
||||
| G.isNewTyCon typ = Just "newtype"
|
||||
| G.isClassTyCon typ = Just "class"
|
||||
| G.isSynTyCon typ = Just "type"
|
||||
| Gap.isSynTyCon typ = Just "type"
|
||||
| otherwise = Nothing
|
||||
|
||||
removeForAlls :: Type -> Type
|
||||
|
@ -1,58 +0,0 @@
|
||||
-- Copyright : Isaac Jones 2003-2004
|
||||
{- All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are
|
||||
met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
* Redistributions in binary form must reproduce the above
|
||||
copyright notice, this list of conditions and the following
|
||||
disclaimer in the documentation and/or other materials provided
|
||||
with the distribution.
|
||||
|
||||
* Neither the name of Isaac Jones nor the names of other
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
|
||||
|
||||
-- | ComponentLocalBuildInfo for Cabal >= 1.18
|
||||
module Language.Haskell.GhcMod.Cabal18 (
|
||||
ComponentLocalBuildInfo
|
||||
, componentPackageDeps
|
||||
, componentLibraries
|
||||
) where
|
||||
|
||||
import Distribution.Package (InstalledPackageId, PackageId)
|
||||
|
||||
data LibraryName = LibraryName String
|
||||
deriving (Read, Show)
|
||||
|
||||
data ComponentLocalBuildInfo
|
||||
= LibComponentLocalBuildInfo {
|
||||
componentPackageDeps :: [(InstalledPackageId, PackageId)],
|
||||
componentLibraries :: [LibraryName]
|
||||
}
|
||||
| ExeComponentLocalBuildInfo {
|
||||
componentPackageDeps :: [(InstalledPackageId, PackageId)]
|
||||
}
|
||||
| TestComponentLocalBuildInfo {
|
||||
componentPackageDeps :: [(InstalledPackageId, PackageId)]
|
||||
}
|
||||
| BenchComponentLocalBuildInfo {
|
||||
componentPackageDeps :: [(InstalledPackageId, PackageId)]
|
||||
}
|
||||
deriving (Read, Show)
|
@ -1,73 +0,0 @@
|
||||
-- Copyright : Isaac Jones 2003-2004
|
||||
{- All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are
|
||||
met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
|
||||
* Redistributions in binary form must reproduce the above
|
||||
copyright notice, this list of conditions and the following
|
||||
disclaimer in the documentation and/or other materials provided
|
||||
with the distribution.
|
||||
|
||||
* Neither the name of Isaac Jones nor the names of other
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
||||
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
|
||||
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
|
||||
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
|
||||
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
|
||||
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
|
||||
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
|
||||
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
|
||||
|
||||
-- | ComponentLocalBuildInfo for Cabal >= 1.21
|
||||
module Language.Haskell.GhcMod.Cabal21 (
|
||||
ComponentLocalBuildInfo
|
||||
, PackageIdentifier(..)
|
||||
, PackageName(..)
|
||||
, componentPackageDeps
|
||||
, componentLibraries
|
||||
) where
|
||||
|
||||
import Distribution.Package (InstalledPackageId)
|
||||
import Data.Version (Version)
|
||||
|
||||
data LibraryName = LibraryName String
|
||||
deriving (Read, Show)
|
||||
|
||||
newtype PackageName = PackageName { unPackageName :: String }
|
||||
deriving (Read, Show)
|
||||
|
||||
data PackageIdentifier
|
||||
= PackageIdentifier {
|
||||
pkgName :: PackageName,
|
||||
pkgVersion :: Version
|
||||
}
|
||||
deriving (Read, Show)
|
||||
|
||||
type PackageId = PackageIdentifier
|
||||
|
||||
data ComponentLocalBuildInfo
|
||||
= LibComponentLocalBuildInfo {
|
||||
componentPackageDeps :: [(InstalledPackageId, PackageId)],
|
||||
componentLibraries :: [LibraryName]
|
||||
}
|
||||
| ExeComponentLocalBuildInfo {
|
||||
componentPackageDeps :: [(InstalledPackageId, PackageId)]
|
||||
}
|
||||
| TestComponentLocalBuildInfo {
|
||||
componentPackageDeps :: [(InstalledPackageId, PackageId)]
|
||||
}
|
||||
| BenchComponentLocalBuildInfo {
|
||||
componentPackageDeps :: [(InstalledPackageId, PackageId)]
|
||||
}
|
||||
deriving (Read, Show)
|
@ -1,193 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings, CPP #-}
|
||||
|
||||
module Language.Haskell.GhcMod.CabalApi (
|
||||
getCompilerOptions
|
||||
, parseCabalFile
|
||||
, cabalAllBuildInfo
|
||||
, cabalDependPackages
|
||||
, cabalSourceDirs
|
||||
, cabalAllTargets
|
||||
, cabalConfigDependencies
|
||||
) where
|
||||
|
||||
import Language.Haskell.GhcMod.CabalConfig
|
||||
import Language.Haskell.GhcMod.Error
|
||||
import Language.Haskell.GhcMod.Gap (benchmarkBuildInfo, benchmarkTargets,
|
||||
toModuleString)
|
||||
import Language.Haskell.GhcMod.GhcPkg
|
||||
import Language.Haskell.GhcMod.Types
|
||||
|
||||
import MonadUtils (liftIO)
|
||||
import Control.Applicative ((<$>))
|
||||
import qualified Control.Exception as E
|
||||
import Control.Monad (filterM)
|
||||
import Data.Maybe (maybeToList)
|
||||
import Data.Set (fromList, toList)
|
||||
import Distribution.Package (Dependency(Dependency)
|
||||
, PackageName(PackageName))
|
||||
import qualified Distribution.Package as C
|
||||
import Distribution.PackageDescription (PackageDescription, BuildInfo, TestSuite, TestSuiteInterface(..), Executable)
|
||||
import qualified Distribution.PackageDescription as P
|
||||
import Distribution.PackageDescription.Configuration (finalizePackageDescription)
|
||||
import Distribution.PackageDescription.Parse (readPackageDescription)
|
||||
import Distribution.Simple.Compiler (CompilerId(..), CompilerFlavor(..))
|
||||
import Distribution.Simple.Program as C (ghcProgram)
|
||||
import Distribution.Simple.Program.Types (programName, programFindVersion)
|
||||
import Distribution.System (buildPlatform)
|
||||
import Distribution.Text (display)
|
||||
import Distribution.Verbosity (silent)
|
||||
import Distribution.Version (Version)
|
||||
import System.Directory (doesFileExist)
|
||||
import System.FilePath ((</>))
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Getting necessary 'CompilerOptions' from three information sources.
|
||||
getCompilerOptions :: (IOish m, MonadError GhcModError m)
|
||||
=> [GHCOption]
|
||||
-> Cradle
|
||||
-> PackageDescription
|
||||
-> m CompilerOptions
|
||||
getCompilerOptions ghcopts cradle pkgDesc = do
|
||||
gopts <- liftIO $ getGHCOptions ghcopts cradle rdir $ head buildInfos
|
||||
depPkgs <- cabalConfigDependencies cradle (C.packageId pkgDesc)
|
||||
return $ CompilerOptions gopts idirs depPkgs
|
||||
where
|
||||
wdir = cradleCurrentDir cradle
|
||||
rdir = cradleRootDir cradle
|
||||
buildInfos = cabalAllBuildInfo pkgDesc
|
||||
idirs = includeDirectories rdir wdir $ cabalSourceDirs buildInfos
|
||||
|
||||
----------------------------------------------------------------
|
||||
-- Include directories for modules
|
||||
|
||||
cabalBuildDirs :: [FilePath]
|
||||
cabalBuildDirs = ["dist/build", "dist/build/autogen"]
|
||||
|
||||
includeDirectories :: FilePath -> FilePath -> [FilePath] -> [FilePath]
|
||||
includeDirectories cdir wdir dirs = uniqueAndSort (extdirs ++ [cdir,wdir])
|
||||
where
|
||||
extdirs = map expand $ dirs ++ cabalBuildDirs
|
||||
expand "." = cdir
|
||||
expand subdir = cdir </> subdir
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Parse a cabal file and return a 'PackageDescription'.
|
||||
parseCabalFile :: (IOish m, MonadError GhcModError m)
|
||||
=> Cradle
|
||||
-> FilePath
|
||||
-> m PackageDescription
|
||||
parseCabalFile cradle file = do
|
||||
cid <- liftIO getGHCId
|
||||
epgd <- liftIO $ readPackageDescription silent file
|
||||
flags <- cabalConfigFlags cradle
|
||||
case toPkgDesc cid flags epgd of
|
||||
Left deps -> fail $ show deps ++ " are not installed"
|
||||
Right (pd,_) -> if nullPkg pd
|
||||
then fail $ file ++ " is broken"
|
||||
else return pd
|
||||
where
|
||||
toPkgDesc cid flags =
|
||||
finalizePackageDescription flags (const True) buildPlatform cid []
|
||||
nullPkg pd = name == ""
|
||||
where
|
||||
PackageName name = C.pkgName (P.package pd)
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
getGHCOptions :: [GHCOption] -> Cradle -> FilePath -> BuildInfo -> IO [GHCOption]
|
||||
getGHCOptions ghcopts cradle rdir binfo = do
|
||||
cabalCpp <- cabalCppOptions rdir
|
||||
let cpps = map ("-optP" ++) $ P.cppOptions binfo ++ cabalCpp
|
||||
return $ ghcopts ++ pkgDb ++ exts ++ [lang] ++ libs ++ libDirs ++ cpps
|
||||
where
|
||||
pkgDb = ghcDbStackOpts $ cradlePkgDbStack cradle
|
||||
lang = maybe "-XHaskell98" (("-X" ++) . display) $ P.defaultLanguage binfo
|
||||
libDirs = map ("-L" ++) $ P.extraLibDirs binfo
|
||||
exts = map (("-X" ++) . display) $ P.usedExtensions binfo
|
||||
libs = map ("-l" ++) $ P.extraLibs binfo
|
||||
|
||||
cabalCppOptions :: FilePath -> IO [String]
|
||||
cabalCppOptions dir = do
|
||||
exist <- doesFileExist cabalMacro
|
||||
return $ if exist then
|
||||
["-include", cabalMacro]
|
||||
else
|
||||
[]
|
||||
where
|
||||
cabalMacro = dir </> "dist/build/autogen/cabal_macros.h"
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Extracting all 'BuildInfo' for libraries, executables, and tests.
|
||||
cabalAllBuildInfo :: PackageDescription -> [BuildInfo]
|
||||
cabalAllBuildInfo pd = libBI ++ execBI ++ testBI ++ benchBI
|
||||
where
|
||||
libBI = map P.libBuildInfo $ maybeToList $ P.library pd
|
||||
execBI = map P.buildInfo $ P.executables pd
|
||||
testBI = map P.testBuildInfo $ P.testSuites pd
|
||||
benchBI = benchmarkBuildInfo pd
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Extracting package names of dependency.
|
||||
cabalDependPackages :: [BuildInfo] -> [PackageBaseName]
|
||||
cabalDependPackages bis = uniqueAndSort pkgs
|
||||
where
|
||||
pkgs = map getDependencyPackageName $ concatMap P.targetBuildDepends bis
|
||||
getDependencyPackageName (Dependency (PackageName nm) _) = nm
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Extracting include directories for modules.
|
||||
cabalSourceDirs :: [BuildInfo] -> [IncludeDir]
|
||||
cabalSourceDirs bis = uniqueAndSort $ concatMap P.hsSourceDirs bis
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
uniqueAndSort :: [String] -> [String]
|
||||
uniqueAndSort = toList . fromList
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
getGHCId :: IO CompilerId
|
||||
getGHCId = CompilerId GHC <$> getGHC
|
||||
|
||||
getGHC :: IO Version
|
||||
getGHC = do
|
||||
mv <- programFindVersion C.ghcProgram silent (programName C.ghcProgram)
|
||||
case mv of
|
||||
-- TODO: MonadError it up
|
||||
Nothing -> E.throwIO $ userError "ghc not found"
|
||||
Just v -> return v
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Extracting all 'Module' 'FilePath's for libraries, executables,
|
||||
-- tests and benchmarks.
|
||||
cabalAllTargets :: PackageDescription -> IO ([String],[String],[String],[String])
|
||||
cabalAllTargets pd = do
|
||||
exeTargets <- mapM getExecutableTarget $ P.executables pd
|
||||
testTargets <- mapM getTestTarget $ P.testSuites pd
|
||||
return (libTargets,concat exeTargets,concat testTargets,benchTargets)
|
||||
where
|
||||
lib = case P.library pd of
|
||||
Nothing -> []
|
||||
Just l -> P.libModules l
|
||||
|
||||
libTargets = map toModuleString lib
|
||||
benchTargets = benchmarkTargets pd
|
||||
|
||||
getTestTarget :: TestSuite -> IO [String]
|
||||
getTestTarget ts =
|
||||
case P.testInterface ts of
|
||||
(TestSuiteExeV10 _ filePath) -> do
|
||||
let maybeTests = [p </> e | p <- P.hsSourceDirs $ P.testBuildInfo ts, e <- [filePath]]
|
||||
liftIO $ filterM doesFileExist maybeTests
|
||||
(TestSuiteLibV09 _ moduleName) -> return [toModuleString moduleName]
|
||||
(TestSuiteUnsupported _) -> return []
|
||||
|
||||
getExecutableTarget :: Executable -> IO [String]
|
||||
getExecutableTarget exe = do
|
||||
let maybeExes = [p </> e | p <- P.hsSourceDirs $ P.buildInfo exe, e <- [P.modulePath exe]]
|
||||
liftIO $ filterM doesFileExist maybeExes
|
@ -1,171 +0,0 @@
|
||||
{-# LANGUAGE RecordWildCards, CPP #-}
|
||||
|
||||
-- | This module facilitates extracting information from Cabal's on-disk
|
||||
-- 'LocalBuildInfo' (@dist/setup-config@).
|
||||
module Language.Haskell.GhcMod.CabalConfig (
|
||||
CabalConfig
|
||||
, cabalConfigDependencies
|
||||
, cabalConfigFlags
|
||||
) where
|
||||
|
||||
import Language.Haskell.GhcMod.Error
|
||||
import Language.Haskell.GhcMod.GhcPkg
|
||||
import Language.Haskell.GhcMod.PathsAndFiles
|
||||
import Language.Haskell.GhcMod.Read
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Utils
|
||||
import Language.Haskell.GhcMod.World
|
||||
|
||||
import qualified Language.Haskell.GhcMod.Cabal16 as C16
|
||||
import qualified Language.Haskell.GhcMod.Cabal18 as C18
|
||||
import qualified Language.Haskell.GhcMod.Cabal21 as C21
|
||||
|
||||
#ifndef MIN_VERSION_mtl
|
||||
#define MIN_VERSION_mtl(x,y,z) 1
|
||||
#endif
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Monad (void, mplus, when)
|
||||
#if MIN_VERSION_mtl(2,2,1)
|
||||
import Control.Monad.Except ()
|
||||
#else
|
||||
import Control.Monad.Error ()
|
||||
#endif
|
||||
import Data.List (find,tails,isPrefixOf,isInfixOf,nub,stripPrefix)
|
||||
import Distribution.Package (InstalledPackageId(..)
|
||||
, PackageIdentifier(..)
|
||||
, PackageName(..))
|
||||
import Distribution.PackageDescription (FlagAssignment)
|
||||
import Distribution.Simple.LocalBuildInfo (ComponentName)
|
||||
import MonadUtils (liftIO)
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | 'Show'ed cabal 'LocalBuildInfo' string
|
||||
type CabalConfig = String
|
||||
|
||||
-- | Get contents of the file containing 'LocalBuildInfo' data. If it doesn't
|
||||
-- exist run @cabal configure@ i.e. configure with default options like @cabal
|
||||
-- build@ would do.
|
||||
getConfig :: (IOish m, MonadError GhcModError m)
|
||||
=> Cradle
|
||||
-> m CabalConfig
|
||||
getConfig cradle = do
|
||||
outOfDate <- liftIO $ isSetupConfigOutOfDate cradle
|
||||
when outOfDate configure
|
||||
liftIO (readFile file) `tryFix` \_ ->
|
||||
configure `modifyError'` GMECabalConfigure
|
||||
where
|
||||
file = setupConfigFile cradle
|
||||
prjDir = cradleRootDir cradle
|
||||
|
||||
configure :: (IOish m, MonadError GhcModError m) => m ()
|
||||
configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"]
|
||||
|
||||
-- | Get list of 'Package's needed by all components of the current package
|
||||
cabalConfigDependencies :: (IOish m, MonadError GhcModError m)
|
||||
=> Cradle
|
||||
-> PackageIdentifier
|
||||
-> m [Package]
|
||||
cabalConfigDependencies cradle thisPkg =
|
||||
configDependencies thisPkg <$> getConfig cradle
|
||||
|
||||
-- | Extract list of depencenies for all components from 'CabalConfig'
|
||||
configDependencies :: PackageIdentifier -> CabalConfig -> [Package]
|
||||
configDependencies thisPkg config = map fromInstalledPackageId deps
|
||||
where
|
||||
deps :: [InstalledPackageId]
|
||||
deps = case deps21 `mplus` deps18 `mplus` deps16 of
|
||||
Right ps -> ps
|
||||
Left msg -> error msg
|
||||
|
||||
-- True if this dependency is an internal one (depends on the library
|
||||
-- defined in the same package).
|
||||
internal pkgid = pkgid == thisPkg
|
||||
|
||||
-- Cabal >= 1.21
|
||||
deps21 :: Either String [InstalledPackageId]
|
||||
deps21 =
|
||||
map fst
|
||||
<$> filterInternal21
|
||||
<$> (readEither =<< extractField config "componentsConfigs")
|
||||
|
||||
filterInternal21
|
||||
:: [(ComponentName, C21.ComponentLocalBuildInfo, [ComponentName])]
|
||||
-> [(InstalledPackageId, C21.PackageIdentifier)]
|
||||
|
||||
filterInternal21 ccfg = [ (ipkgid, pkgid)
|
||||
| (_,clbi,_) <- ccfg
|
||||
, (ipkgid, pkgid) <- C21.componentPackageDeps clbi
|
||||
, not (internal . packageIdentifierFrom21 $ pkgid) ]
|
||||
|
||||
packageIdentifierFrom21 :: C21.PackageIdentifier -> PackageIdentifier
|
||||
packageIdentifierFrom21 (C21.PackageIdentifier (C21.PackageName myName) myVersion) =
|
||||
PackageIdentifier (PackageName myName) myVersion
|
||||
|
||||
-- Cabal >= 1.18 && < 1.21
|
||||
deps18 :: Either String [InstalledPackageId]
|
||||
deps18 =
|
||||
map fst
|
||||
<$> filterInternal
|
||||
<$> (readEither =<< extractField config "componentsConfigs")
|
||||
|
||||
filterInternal
|
||||
:: [(ComponentName, C18.ComponentLocalBuildInfo, [ComponentName])]
|
||||
-> [(InstalledPackageId, PackageIdentifier)]
|
||||
|
||||
filterInternal ccfg = [ (ipkgid, pkgid)
|
||||
| (_,clbi,_) <- ccfg
|
||||
, (ipkgid, pkgid) <- C18.componentPackageDeps clbi
|
||||
, not (internal pkgid) ]
|
||||
|
||||
-- Cabal 1.16 and below
|
||||
deps16 :: Either String [InstalledPackageId]
|
||||
deps16 = map fst <$> filter (not . internal . snd) . nub <$> do
|
||||
cbi <- concat <$> sequence [ extract "executableConfigs"
|
||||
, extract "testSuiteConfigs"
|
||||
, extract "benchmarkConfigs" ]
|
||||
:: Either String [(String, C16.ComponentLocalBuildInfo)]
|
||||
|
||||
return $ maybe [] C16.componentPackageDeps libraryConfig
|
||||
++ concatMap (C16.componentPackageDeps . snd) cbi
|
||||
where
|
||||
libraryConfig :: Maybe C16.ComponentLocalBuildInfo
|
||||
libraryConfig = do
|
||||
field <- find ("libraryConfig" `isPrefixOf`) (tails config)
|
||||
clbi <- stripPrefix " = " field
|
||||
if "Nothing" `isPrefixOf` clbi
|
||||
then Nothing
|
||||
else case readMaybe =<< stripPrefix "Just " clbi of
|
||||
Just x -> x
|
||||
Nothing -> error $ "reading libraryConfig failed\n" ++ show (stripPrefix "Just " clbi)
|
||||
|
||||
extract :: String -> Either String [(String, C16.ComponentLocalBuildInfo)]
|
||||
extract field = readConfigs field <$> extractField config field
|
||||
|
||||
readConfigs :: String -> String -> [(String, C16.ComponentLocalBuildInfo)]
|
||||
readConfigs f s = case readEither s of
|
||||
Right x -> x
|
||||
Left msg -> error $ "reading config " ++ f ++ " failed ("++msg++")"
|
||||
|
||||
-- | Get the flag assignment from the local build info of the given cradle
|
||||
cabalConfigFlags :: (IOish m, MonadError GhcModError m)
|
||||
=> Cradle
|
||||
-> m FlagAssignment
|
||||
cabalConfigFlags cradle = do
|
||||
config <- getConfig cradle
|
||||
case configFlags config of
|
||||
Right x -> return x
|
||||
Left msg -> throwError (GMECabalFlags (GMEString msg))
|
||||
|
||||
-- | Extract the cabal flags from the 'CabalConfig'
|
||||
configFlags :: CabalConfig -> Either String FlagAssignment
|
||||
configFlags config = readEither =<< flip extractField "configConfigurationsFlags" =<< extractField config "configFlags"
|
||||
|
||||
-- | Find @field@ in 'CabalConfig'. Returns 'Left' containing a user readable
|
||||
-- error message with lots of context on failure.
|
||||
extractField :: CabalConfig -> String -> Either String String
|
||||
extractField config field =
|
||||
case extractParens <$> find (field `isPrefixOf`) (tails config) of
|
||||
Just f -> Right f
|
||||
Nothing -> Left $ "extractField: failed extracting "++field++" from input, input contained `"++field++"'? " ++ show (field `isInfixOf` config)
|
228
Language/Haskell/GhcMod/CabalHelper.hs
Normal file
228
Language/Haskell/GhcMod/CabalHelper.hs
Normal 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
103
Language/Haskell/GhcMod/Caching.hs
Normal 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
52
Language/Haskell/GhcMod/Caching/Types.hs
Normal 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]))
|
@ -8,17 +8,24 @@ import Data.List (find, intercalate)
|
||||
import Data.Maybe (isJust)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T (readFile)
|
||||
import System.FilePath
|
||||
|
||||
import qualified DataCon as Ty
|
||||
import Exception (ghandle, SomeException(..))
|
||||
import GHC (GhcMonad, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
|
||||
import qualified GHC as G
|
||||
import Language.Haskell.GhcMod.Convert
|
||||
import qualified Language.Haskell.GhcMod.Gap as Gap
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.SrcUtils
|
||||
import Outputable (PprStyle)
|
||||
import qualified TyCon as Ty
|
||||
import qualified Type as Ty
|
||||
import Exception
|
||||
|
||||
import Language.Haskell.GhcMod.Convert
|
||||
import Language.Haskell.GhcMod.DynFlags
|
||||
import qualified Language.Haskell.GhcMod.Gap as Gap
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.SrcUtils
|
||||
import Language.Haskell.GhcMod.Doc
|
||||
import Language.Haskell.GhcMod.Logging
|
||||
import Language.Haskell.GhcMod.Types
|
||||
|
||||
----------------------------------------------------------------
|
||||
-- CASE SPLITTING
|
||||
@ -38,23 +45,29 @@ splits :: IOish m
|
||||
-> Int -- ^ Line number.
|
||||
-> Int -- ^ Column number.
|
||||
-> GhcModT m String
|
||||
splits file lineNo colNo = ghandle handler body
|
||||
where
|
||||
body = inModuleContext file $ \dflag style -> do
|
||||
splits file lineNo colNo =
|
||||
ghandle handler $ runGmlT' [Left file] deferErrors $ do
|
||||
opt <- options
|
||||
modSum <- Gap.fileModSummary file
|
||||
crdl <- cradle
|
||||
style <- getStyle
|
||||
dflag <- G.getSessionDynFlags
|
||||
modSum <- Gap.fileModSummary (cradleCurrentDir crdl </> file)
|
||||
whenFound' opt (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of
|
||||
(SplitInfo varName bndLoc (varLoc,varT) _matches) -> do
|
||||
let varName' = showName dflag style varName -- Convert name to string
|
||||
text <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
|
||||
t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
|
||||
getTyCons dflag style varName varT)
|
||||
return (fourInts bndLoc, text)
|
||||
return (fourInts bndLoc, t)
|
||||
(TySplitInfo varName bndLoc (varLoc,varT)) -> do
|
||||
let varName' = showName dflag style varName -- Convert name to string
|
||||
text <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
|
||||
t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
|
||||
getTyCons dflag style varName varT)
|
||||
return (fourInts bndLoc, text)
|
||||
handler (SomeException _) = emptyResult =<< options
|
||||
return (fourInts bndLoc, t)
|
||||
where
|
||||
handler (SomeException ex) = do
|
||||
gmLog GmDebug "splits" $
|
||||
text "" $$ nest 4 (showDoc ex)
|
||||
emptyResult =<< options
|
||||
|
||||
----------------------------------------------------------------
|
||||
-- a. Code for getting the information of the variable
|
||||
@ -79,7 +92,11 @@ getSrcSpanTypeForFnSplit modSum lineNo colNo = do
|
||||
varT <- Gap.getType tcm varPat' -- Finally we get the type of the var
|
||||
case varT of
|
||||
Just varT' ->
|
||||
#if __GLASGOW_HASKELL__ >= 710
|
||||
let (L matchL (G.Match _ _ _ (G.GRHSs rhsLs _))) = match
|
||||
#else
|
||||
let (L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match
|
||||
#endif
|
||||
in return $ Just (SplitInfo (getPatternVarName varPat') matchL varT' (map G.getLoc rhsLs) )
|
||||
_ -> return Nothing
|
||||
|
||||
@ -178,15 +195,16 @@ showFieldNames dflag style v (x:xs) = let fName = showName dflag style x
|
||||
----------------------------------------------------------------
|
||||
-- c. Code for performing the case splitting
|
||||
|
||||
genCaseSplitTextFile :: GhcMonad m => FilePath -> SplitToTextInfo -> m String
|
||||
genCaseSplitTextFile :: (MonadIO m, GhcMonad m) =>
|
||||
FilePath -> SplitToTextInfo -> m String
|
||||
genCaseSplitTextFile file info = liftIO $ do
|
||||
text <- T.readFile file
|
||||
return $ getCaseSplitText (T.lines text) info
|
||||
t <- T.readFile file
|
||||
return $ getCaseSplitText (T.lines t) info
|
||||
|
||||
getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String
|
||||
getCaseSplitText text (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS
|
||||
getCaseSplitText t (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS
|
||||
, sVarSpan = sVS, sTycons = sT }) =
|
||||
let bindingText = getBindingText text sBS
|
||||
let bindingText = getBindingText t sBS
|
||||
difference = srcSpanDifference sBS sVS
|
||||
replaced = map (replaceVarWithTyCon bindingText difference sVN) sT
|
||||
-- The newly generated bindings need to be indented to align with the
|
||||
@ -195,9 +213,9 @@ getCaseSplitText text (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS
|
||||
in T.unpack $ T.intercalate (T.pack "\n") (concat replaced')
|
||||
|
||||
getBindingText :: [T.Text] -> SrcSpan -> [T.Text]
|
||||
getBindingText text srcSpan =
|
||||
getBindingText t srcSpan =
|
||||
let Just (sl,sc,el,ec) = Gap.getSrcSpan srcSpan
|
||||
lines_ = drop (sl - 1) $ take el text
|
||||
lines_ = drop (sl - 1) $ take el t
|
||||
in if sl == el
|
||||
then -- only one line
|
||||
[T.drop (sc - 1) $ T.take ec $ head lines_]
|
||||
@ -212,7 +230,7 @@ srcSpanDifference b v =
|
||||
in (vsl - bsl, vsc - bsc, vel - bsl, vec - bsc) -- assume variable in one line
|
||||
|
||||
replaceVarWithTyCon :: [T.Text] -> (Int,Int,Int,Int) -> String -> String -> [T.Text]
|
||||
replaceVarWithTyCon text (vsl,vsc,_,vec) varname tycon =
|
||||
replaceVarWithTyCon t (vsl,vsc,_,vec) varname tycon =
|
||||
let tycon' = if ' ' `elem` tycon || ':' `elem` tycon then "(" ++ tycon ++ ")" else tycon
|
||||
lengthDiff = length tycon' - length varname
|
||||
tycon'' = T.pack $ if lengthDiff < 0 then tycon' ++ replicate (-lengthDiff) ' ' else tycon'
|
||||
@ -222,7 +240,7 @@ replaceVarWithTyCon text (vsl,vsc,_,vec) varname tycon =
|
||||
else if n == vsl
|
||||
then T.take vsc line `T.append` tycon'' `T.append` T.drop vec line
|
||||
else T.replicate spacesToAdd (T.pack " ") `T.append` line)
|
||||
[0 ..] text
|
||||
[0 ..] t
|
||||
|
||||
indentBindingTo :: SrcSpan -> [T.Text] -> [T.Text]
|
||||
indentBindingTo bndLoc binds =
|
||||
|
@ -5,12 +5,12 @@ module Language.Haskell.GhcMod.Check (
|
||||
, expand
|
||||
) where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Applicative
|
||||
import Prelude
|
||||
import Language.Haskell.GhcMod.DynFlags
|
||||
import qualified Language.Haskell.GhcMod.Gap as Gap
|
||||
import Language.Haskell.GhcMod.Logger
|
||||
import Language.Haskell.GhcMod.Monad (IOish, GhcModT)
|
||||
import Language.Haskell.GhcMod.Target (setTargetFiles)
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
@ -29,15 +29,12 @@ checkSyntax files = either id id <$> check files
|
||||
check :: IOish m
|
||||
=> [FilePath] -- ^ The target files.
|
||||
-> GhcModT m (Either String String)
|
||||
{-
|
||||
check fileNames = overrideGhcUserOptions $ \ghcOpts -> do
|
||||
withLogger (setAllWarningFlags . setNoMaxRelevantBindings . Gap.setWarnTypedHoles . Gap.setDeferTypeErrors) $ do
|
||||
_ <- G.setSessionDynFlags =<< addCmdOpts ghcOpts =<< G.getSessionDynFlags
|
||||
setTargetFiles fileNames
|
||||
-}
|
||||
check fileNames =
|
||||
withLogger (setAllWarningFlags . setNoMaxRelevantBindings) $
|
||||
setTargetFiles fileNames
|
||||
check files =
|
||||
runGmlTWith
|
||||
(map Left files)
|
||||
return
|
||||
((fmap fst <$>) . withLogger setNoMaxRelevantBindings)
|
||||
(return ())
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
@ -51,8 +48,10 @@ expandTemplate files = either id id <$> expand files
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Expanding Haskell Template.
|
||||
expand :: IOish m
|
||||
=> [FilePath] -- ^ The target files.
|
||||
-> GhcModT m (Either String String)
|
||||
expand fileNames = withLogger (Gap.setDumpSplices . setNoWarningFlags) $
|
||||
setTargetFiles fileNames
|
||||
expand :: IOish m => [FilePath] -> GhcModT m (Either String String)
|
||||
expand files =
|
||||
runGmlTWith
|
||||
(map Left files)
|
||||
return
|
||||
((fmap fst <$>) . withLogger (Gap.setDumpSplices . setNoWarningFlags))
|
||||
(return ())
|
||||
|
@ -1,11 +1,12 @@
|
||||
{-# LANGUAGE FlexibleInstances, FlexibleContexts, OverlappingInstances #-}
|
||||
{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-}
|
||||
|
||||
module Language.Haskell.GhcMod.Convert (convert, convert', emptyResult, whenFound, whenFound') where
|
||||
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.Monad.Types
|
||||
import Language.Haskell.GhcMod.Types
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Applicative
|
||||
import Prelude
|
||||
|
||||
type Builder = String -> String
|
||||
|
||||
@ -23,7 +24,7 @@ inter :: Char -> [Builder] -> Builder
|
||||
inter _ [] = id
|
||||
inter c bs = foldr1 (\x y -> x . (c:) . y) bs
|
||||
|
||||
convert' :: (ToString a, IOish m) => a -> GhcModT m String
|
||||
convert' :: (ToString a, IOish m, GmEnv m) => a -> m String
|
||||
convert' x = flip convert x <$> options
|
||||
|
||||
convert :: ToString a => Options -> a -> String
|
||||
@ -64,6 +65,10 @@ instance ToString [String] where
|
||||
toLisp opt = toSexp1 opt
|
||||
toPlain opt = inter '\n' . map (toPlain opt)
|
||||
|
||||
instance ToString [ModuleString] where
|
||||
toLisp opt = toLisp opt . map getModuleString
|
||||
toPlain opt = toPlain opt . map getModuleString
|
||||
|
||||
-- |
|
||||
--
|
||||
-- >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)]
|
||||
|
@ -1,19 +1,22 @@
|
||||
module Language.Haskell.GhcMod.Cradle (
|
||||
findCradle
|
||||
, findCradle'
|
||||
, findCradleWithoutSandbox
|
||||
, findSpecCradle
|
||||
, cleanupCradle
|
||||
) where
|
||||
|
||||
import Language.Haskell.GhcMod.GhcPkg
|
||||
import Language.Haskell.GhcMod.PathsAndFiles
|
||||
import Language.Haskell.GhcMod.Monad.Types
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Utils
|
||||
|
||||
import Control.Exception.IOChoice ((||>))
|
||||
import System.Directory (getCurrentDirectory, removeDirectoryRecursive)
|
||||
import System.FilePath (takeDirectory)
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Data.Maybe
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
import Prelude
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
@ -25,51 +28,62 @@ findCradle :: IO Cradle
|
||||
findCradle = findCradle' =<< getCurrentDirectory
|
||||
|
||||
findCradle' :: FilePath -> IO Cradle
|
||||
findCradle' dir = cabalCradle dir ||> sandboxCradle dir ||> plainCradle dir
|
||||
findCradle' dir = run $ do
|
||||
(cabalCradle dir `mplus` sandboxCradle dir `mplus` plainCradle dir)
|
||||
where run a = fillTempDir =<< (fromJust <$> runMaybeT a)
|
||||
|
||||
findSpecCradle :: FilePath -> IO Cradle
|
||||
findSpecCradle dir = do
|
||||
let cfs = [cabalCradle, sandboxCradle]
|
||||
cs <- catMaybes <$> mapM (runMaybeT . ($ dir)) cfs
|
||||
gcs <- filterM isNotGmCradle cs
|
||||
fillTempDir =<< case gcs of
|
||||
[] -> fromJust <$> runMaybeT (plainCradle dir)
|
||||
c:_ -> return c
|
||||
where
|
||||
isNotGmCradle :: Cradle -> IO Bool
|
||||
isNotGmCradle crdl = do
|
||||
not <$> doesFileExist (cradleRootDir crdl </> "ghc-mod.cabal")
|
||||
|
||||
cleanupCradle :: Cradle -> IO ()
|
||||
cleanupCradle crdl = removeDirectoryRecursive $ cradleTempDir crdl
|
||||
|
||||
cabalCradle :: FilePath -> IO Cradle
|
||||
fillTempDir :: MonadIO m => Cradle -> m Cradle
|
||||
fillTempDir crdl = do
|
||||
tmpDir <- liftIO $ newTempDir (cradleRootDir crdl)
|
||||
return crdl { cradleTempDir = tmpDir }
|
||||
|
||||
cabalCradle :: FilePath -> MaybeT IO Cradle
|
||||
cabalCradle wdir = do
|
||||
Just cabalFile <- findCabalFile wdir
|
||||
cabalFile <- MaybeT $ findCabalFile wdir
|
||||
|
||||
let cabalDir = takeDirectory cabalFile
|
||||
pkgDbStack <- getPackageDbStack cabalDir
|
||||
tmpDir <- newTempDir cabalDir
|
||||
|
||||
return Cradle {
|
||||
cradleCurrentDir = wdir
|
||||
cradleProjectType = CabalProject
|
||||
, cradleCurrentDir = wdir
|
||||
, cradleRootDir = cabalDir
|
||||
, cradleTempDir = tmpDir
|
||||
, cradleTempDir = error "tmpDir"
|
||||
, cradleCabalFile = Just cabalFile
|
||||
, cradlePkgDbStack = pkgDbStack
|
||||
}
|
||||
|
||||
sandboxCradle :: FilePath -> IO Cradle
|
||||
sandboxCradle :: FilePath -> MaybeT IO Cradle
|
||||
sandboxCradle wdir = do
|
||||
Just sbDir <- getSandboxDb wdir
|
||||
pkgDbStack <- getPackageDbStack sbDir
|
||||
tmpDir <- newTempDir sbDir
|
||||
sbDir <- MaybeT $ findCabalSandboxDir wdir
|
||||
return Cradle {
|
||||
cradleCurrentDir = wdir
|
||||
cradleProjectType = SandboxProject
|
||||
, cradleCurrentDir = wdir
|
||||
, cradleRootDir = sbDir
|
||||
, cradleTempDir = tmpDir
|
||||
, cradleTempDir = error "tmpDir"
|
||||
, cradleCabalFile = Nothing
|
||||
, cradlePkgDbStack = pkgDbStack
|
||||
}
|
||||
|
||||
plainCradle :: FilePath -> IO Cradle
|
||||
plainCradle :: FilePath -> MaybeT IO Cradle
|
||||
plainCradle wdir = do
|
||||
tmpDir <- newTempDir wdir
|
||||
return Cradle {
|
||||
cradleCurrentDir = wdir
|
||||
return $ Cradle {
|
||||
cradleProjectType = PlainProject
|
||||
, cradleCurrentDir = wdir
|
||||
, cradleRootDir = wdir
|
||||
, cradleTempDir = tmpDir
|
||||
, cradleTempDir = error "tmpDir"
|
||||
, cradleCabalFile = Nothing
|
||||
, cradlePkgDbStack = [GlobalDb, UserDb]
|
||||
}
|
||||
|
||||
-- Just for testing
|
||||
findCradleWithoutSandbox :: IO Cradle
|
||||
findCradleWithoutSandbox = do
|
||||
cradle <- findCradle
|
||||
return cradle { cradlePkgDbStack = [GlobalDb]} -- FIXME
|
||||
|
@ -1,39 +1,127 @@
|
||||
module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo) where
|
||||
module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo, componentInfo) where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Data.List (intercalate)
|
||||
import Data.Maybe (isJust, fromJust)
|
||||
import Control.Arrow (first)
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import Data.Char
|
||||
import Data.List.Split
|
||||
import Text.PrettyPrint
|
||||
import Language.Haskell.GhcMod.Convert
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Internal
|
||||
import Language.Haskell.GhcMod.Target
|
||||
import Language.Haskell.GhcMod.Pretty
|
||||
import Language.Haskell.GhcMod.Utils
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Obtaining debug information.
|
||||
debugInfo :: IOish m => GhcModT m String
|
||||
debugInfo = cradle >>= \c -> convert' =<< do
|
||||
CompilerOptions gopts incDir pkgs <-
|
||||
if isJust $ cradleCabalFile c then
|
||||
fromCabalFile c ||> simpleCompilerOption
|
||||
else
|
||||
simpleCompilerOption
|
||||
return [
|
||||
"Root directory: " ++ cradleRootDir c
|
||||
, "Current directory: " ++ cradleCurrentDir c
|
||||
, "Cabal file: " ++ show (cradleCabalFile c)
|
||||
, "GHC options: " ++ unwords gopts
|
||||
, "Include directories: " ++ unwords incDir
|
||||
, "Dependent packages: " ++ intercalate ", " (map showPkg pkgs)
|
||||
, "System libraries: " ++ ghcLibDir
|
||||
debugInfo = do
|
||||
Options {..} <- options
|
||||
Cradle {..} <- cradle
|
||||
|
||||
cabal <-
|
||||
case cradleProjectType of
|
||||
CabalProject -> cabalDebug
|
||||
_ -> return []
|
||||
|
||||
pkgOpts <- packageGhcOptions
|
||||
|
||||
return $ unlines $
|
||||
[ "Root directory: " ++ cradleRootDir
|
||||
, "Current directory: " ++ cradleCurrentDir
|
||||
, "GHC Package flags:\n" ++ render (nest 4 $
|
||||
fsep $ map text pkgOpts)
|
||||
, "GHC System libraries: " ++ ghcLibDir
|
||||
, "GHC user options:\n" ++ render (nest 4 $
|
||||
fsep $ map text ghcUserOptions)
|
||||
] ++ cabal
|
||||
|
||||
cabalDebug :: IOish m => GhcModT m [String]
|
||||
cabalDebug = do
|
||||
Cradle {..} <- cradle
|
||||
mcs <- cabalResolvedComponents
|
||||
let entrypoints = Map.map gmcEntrypoints mcs
|
||||
graphs = Map.map gmcHomeModuleGraph mcs
|
||||
opts = Map.map gmcGhcOpts mcs
|
||||
srcOpts = Map.map gmcGhcSrcOpts mcs
|
||||
|
||||
return $
|
||||
[ "Cabal file: " ++ show cradleCabalFile
|
||||
, "Cabal entrypoints:\n" ++ render (nest 4 $
|
||||
mapDoc gmComponentNameDoc smpDoc entrypoints)
|
||||
, "Cabal components:\n" ++ render (nest 4 $
|
||||
mapDoc gmComponentNameDoc graphDoc graphs)
|
||||
, "GHC Cabal options:\n" ++ render (nest 4 $
|
||||
mapDoc gmComponentNameDoc (fsep . map text) opts)
|
||||
, "GHC search path options:\n" ++ render (nest 4 $
|
||||
mapDoc gmComponentNameDoc (fsep . map text) srcOpts)
|
||||
]
|
||||
|
||||
componentInfo :: IOish m => [String] -> GhcModT m String
|
||||
componentInfo ts = do
|
||||
-- TODO: most of this is copypasta of targetGhcOptions. Factor out more
|
||||
-- useful function from there.
|
||||
crdl <- cradle
|
||||
sefnmn <- Set.fromList `liftM` mapM guessModuleFile ts
|
||||
mcs <- cabalResolvedComponents
|
||||
let
|
||||
mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn
|
||||
candidates = findCandidates $ map snd mdlcs
|
||||
cn = pickComponent candidates
|
||||
opts <- targetGhcOptions crdl sefnmn
|
||||
|
||||
return $ unlines $
|
||||
[ "Matching Components:\n" ++ render (nest 4 $
|
||||
alistDoc (either text mnDoc) (setDoc gmComponentNameDoc) mdlcs)
|
||||
, "Picked Component:\n" ++ render (nest 4 $
|
||||
gmComponentNameDoc cn)
|
||||
, "GHC Cabal options:\n" ++ render (nest 4 $ fsep $ map text opts)
|
||||
]
|
||||
where
|
||||
simpleCompilerOption = options >>= \op ->
|
||||
return $ CompilerOptions (ghcUserOptions op) [] []
|
||||
fromCabalFile c = options >>= \opts -> do
|
||||
pkgDesc <- parseCabalFile c $ fromJust $ cradleCabalFile c
|
||||
getCompilerOptions (ghcUserOptions opts) c pkgDesc
|
||||
zipMap f l = l `zip` (f `map` l)
|
||||
|
||||
guessModuleFile :: MonadIO m => String -> m (Either FilePath ModuleName)
|
||||
guessModuleFile m
|
||||
| (isUpper . head .&&. (all $ all $ isAlphaNum .||. (=='.')) . splitOn ".") m =
|
||||
return $ Right $ mkModuleName m
|
||||
where
|
||||
infixr 1 .||.
|
||||
infixr 2 .&&.
|
||||
(.||.) = liftA2 (||)
|
||||
(.&&.) = liftA2 (&&)
|
||||
|
||||
guessModuleFile str = Left `liftM` liftIO (canonFilePath str)
|
||||
|
||||
graphDoc :: GmModuleGraph -> Doc
|
||||
graphDoc GmModuleGraph{..} =
|
||||
mapDoc mpDoc smpDoc' gmgGraph
|
||||
where
|
||||
smpDoc' smp = vcat $ map mpDoc' $ Set.toList smp
|
||||
mpDoc' = text . moduleNameString . mpModule
|
||||
|
||||
setDoc :: (a -> Doc) -> Set.Set a -> Doc
|
||||
setDoc f s = vcat $ map f $ Set.toList s
|
||||
|
||||
smpDoc :: Set.Set ModulePath -> Doc
|
||||
smpDoc smp = setDoc mpDoc smp
|
||||
|
||||
mpDoc :: ModulePath -> Doc
|
||||
mpDoc (ModulePath mn fn) = text (moduleNameString mn) <+> parens (text fn)
|
||||
|
||||
mnDoc :: ModuleName -> Doc
|
||||
mnDoc mn = text (moduleNameString mn)
|
||||
|
||||
alistDoc :: Ord k => (k -> Doc) -> (a -> Doc) -> [(k, a)] -> Doc
|
||||
alistDoc fk fa alist = mapDoc fk fa (Map.fromList alist)
|
||||
|
||||
mapDoc :: (k -> Doc) -> (a -> Doc) -> Map.Map k a -> Doc
|
||||
mapDoc kd ad m = vcat $
|
||||
map (uncurry ($+$)) $ map (first kd) $ Map.toList $ Map.map (nest 4 . ad) m
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Obtaining root information.
|
||||
|
@ -1,9 +1,8 @@
|
||||
module Language.Haskell.GhcMod.Doc where
|
||||
|
||||
import GHC (DynFlags, GhcMonad)
|
||||
import qualified GHC as G
|
||||
import GHC
|
||||
import Language.Haskell.GhcMod.Gap (withStyle, showDocWith)
|
||||
import Outputable (SDoc, PprStyle, mkUserStyle, Depth(AllTheWay), neverQualify)
|
||||
import Outputable
|
||||
import Pretty (Mode(..))
|
||||
|
||||
showPage :: DynFlags -> PprStyle -> SDoc -> String
|
||||
@ -12,9 +11,14 @@ showPage dflag style = showDocWith dflag PageMode . withStyle dflag style
|
||||
showOneLine :: DynFlags -> PprStyle -> SDoc -> String
|
||||
showOneLine dflag style = showDocWith dflag OneLineMode . withStyle dflag style
|
||||
|
||||
-- showForUser :: DynFlags -> PrintUnqualified -> SDoc -> String
|
||||
-- showForUser dflags unqual sdoc =
|
||||
-- showDocWith dflags PageMode $
|
||||
-- runSDoc sdoc $ initSDocContext dflags $ mkUserStyle unqual AllTheWay
|
||||
|
||||
getStyle :: GhcMonad m => m PprStyle
|
||||
getStyle = do
|
||||
unqual <- G.getPrintUnqual
|
||||
unqual <- getPrintUnqual
|
||||
return $ mkUserStyle unqual AllTheWay
|
||||
|
||||
styleUnqualified :: PprStyle
|
||||
|
@ -2,7 +2,7 @@
|
||||
|
||||
module Language.Haskell.GhcMod.DynFlags where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Applicative
|
||||
import Control.Monad (void)
|
||||
import GHC (DynFlags(..), GhcMode(..), GhcLink(..), HscTarget(..))
|
||||
import qualified GHC as G
|
||||
@ -11,8 +11,7 @@ import GhcMonad
|
||||
import qualified Language.Haskell.GhcMod.Gap as Gap
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
|
||||
data Build = CabalPkg | SingleFile deriving Eq
|
||||
import Prelude
|
||||
|
||||
setEmptyLogger :: DynFlags -> DynFlags
|
||||
setEmptyLogger df = Gap.setLogAction df $ \_ _ _ _ _ -> return ()
|
||||
@ -41,37 +40,15 @@ setModeIntelligent df = df {
|
||||
, optLevel = 0
|
||||
}
|
||||
|
||||
setIncludeDirs :: [IncludeDir] -> DynFlags -> DynFlags
|
||||
setIncludeDirs idirs df = df { importPaths = idirs }
|
||||
|
||||
setBuildEnv :: Build -> DynFlags -> DynFlags
|
||||
setBuildEnv build = setHideAllPackages build . setCabalPackage build
|
||||
|
||||
-- | With ghc-7.8 this option simply makes GHC print a message suggesting users
|
||||
-- add hiddend packages to the build-depends field in their cabal file when the
|
||||
-- user tries to import a module form a hidden package.
|
||||
setCabalPackage :: Build -> DynFlags -> DynFlags
|
||||
setCabalPackage CabalPkg df = Gap.setCabalPkg df
|
||||
setCabalPackage _ df = df
|
||||
|
||||
-- | Enable hiding of all package not explicitly exposed (like Cabal does)
|
||||
setHideAllPackages :: Build -> DynFlags -> DynFlags
|
||||
setHideAllPackages CabalPkg df = Gap.setHideAllPackages df
|
||||
setHideAllPackages _ df = df
|
||||
|
||||
-- | Parse command line ghc options and add them to the 'DynFlags' passed
|
||||
addCmdOpts :: GhcMonad m => [GHCOption] -> DynFlags -> m DynFlags
|
||||
addCmdOpts cmdOpts df =
|
||||
tfst <$> G.parseDynamicFlags df (map G.noLoc cmdOpts)
|
||||
fst3 <$> G.parseDynamicFlags df (map G.noLoc cmdOpts)
|
||||
where
|
||||
tfst (a,_,_) = a
|
||||
fst3 (a,_,_) = a
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Return the 'DynFlags' currently in use in the GHC session.
|
||||
getDynamicFlags :: IO DynFlags
|
||||
getDynamicFlags = G.runGhc (Just libdir) G.getSessionDynFlags
|
||||
|
||||
withDynFlags :: GhcMonad m
|
||||
=> (DynFlags -> DynFlags)
|
||||
-> m a
|
||||
@ -119,3 +96,7 @@ setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing }
|
||||
#else
|
||||
setNoMaxRelevantBindings = id
|
||||
#endif
|
||||
|
||||
deferErrors :: DynFlags -> Ghc DynFlags
|
||||
deferErrors df = return $
|
||||
Gap.setWarnTypedHoles $ Gap.setDeferTypeErrors $ setNoWarningFlags df
|
||||
|
@ -1,45 +1,88 @@
|
||||
{-# LANGUAGE TypeFamilies, ScopedTypeVariables, DeriveDataTypeable #-}
|
||||
-- ghc-mod: Making Haskell development *more* fun
|
||||
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
|
||||
--
|
||||
-- This program is free software: you can redistribute it and/or modify
|
||||
-- it under the terms of the GNU Affero General Public License as published by
|
||||
-- the Free Software Foundation, either version 3 of the License, or
|
||||
-- (at your option) any later version.
|
||||
--
|
||||
-- This program is distributed in the hope that it will be useful,
|
||||
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
-- GNU Affero General Public License for more details.
|
||||
--
|
||||
-- You should have received a copy of the GNU Affero General Public License
|
||||
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
module Language.Haskell.GhcMod.Error (
|
||||
GhcModError(..)
|
||||
, GMConfigStateFileError(..)
|
||||
, GmError
|
||||
, gmeDoc
|
||||
, ghcExceptionDoc
|
||||
, liftMaybe
|
||||
, overrideError
|
||||
, modifyError
|
||||
, modifyError'
|
||||
, modifyGmError
|
||||
, tryFix
|
||||
, GHandler(..)
|
||||
, gcatches
|
||||
, module Control.Monad.Error
|
||||
, module Exception
|
||||
, module Control.Exception
|
||||
) where
|
||||
|
||||
import Control.Monad.Error (MonadError(..), Error(..))
|
||||
import Control.Arrow
|
||||
import Control.Exception
|
||||
import Control.Monad.Error hiding (MonadIO, liftIO)
|
||||
import qualified Data.Set as Set
|
||||
import Data.List
|
||||
import Data.Typeable
|
||||
import Exception
|
||||
import Data.Version
|
||||
import System.Process (showCommandForUser)
|
||||
import Text.PrettyPrint
|
||||
import Text.Printf
|
||||
|
||||
data GhcModError = GMENoMsg
|
||||
-- ^ Unknown error
|
||||
| GMEString String
|
||||
-- ^ Some Error with a message. These are produced mostly by
|
||||
-- 'fail' calls on GhcModT.
|
||||
| GMEIOException IOException
|
||||
-- ^ IOExceptions captured by GhcModT's MonadIO instance
|
||||
| GMECabalConfigure GhcModError
|
||||
-- ^ Configuring a cabal project failed.
|
||||
| GMECabalFlags GhcModError
|
||||
-- ^ Retrieval of the cabal configuration flags failed.
|
||||
| GMEProcess [String] GhcModError
|
||||
-- ^ Launching an operating system process failed. The first
|
||||
-- field is the command.
|
||||
| GMENoCabalFile
|
||||
-- ^ No cabal file found.
|
||||
| GMETooManyCabalFiles [FilePath]
|
||||
-- ^ Too many cabal files found.
|
||||
deriving (Eq,Show,Typeable)
|
||||
import Exception
|
||||
import Panic
|
||||
import Config (cProjectVersion, cHostPlatformString)
|
||||
import Paths_ghc_mod (version)
|
||||
|
||||
instance Exception GhcModError
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Pretty
|
||||
|
||||
instance Error GhcModError where
|
||||
noMsg = GMENoMsg
|
||||
strMsg = GMEString
|
||||
type GmError m = MonadError GhcModError m
|
||||
|
||||
gmCsfeDoc :: GMConfigStateFileError -> Doc
|
||||
gmCsfeDoc GMConfigStateFileNoHeader = text $
|
||||
"Saved package config file header is missing. "
|
||||
++ "Try re-running the 'configure' command."
|
||||
|
||||
gmCsfeDoc GMConfigStateFileBadHeader = text $
|
||||
"Saved package config file header is corrupt. "
|
||||
++ "Try re-running the 'configure' command."
|
||||
|
||||
gmCsfeDoc GMConfigStateFileNoParse = text $
|
||||
"Saved package config file body is corrupt. "
|
||||
++ "Try re-running the 'configure' command."
|
||||
|
||||
gmCsfeDoc GMConfigStateFileMissing = text $
|
||||
"Run the 'configure' command first."
|
||||
|
||||
-- gmCsfeDoc (ConfigStateFileBadVersion oldCabal oldCompiler _) = text $
|
||||
-- "You need to re-run the 'configure' command. "
|
||||
-- ++ "The version of Cabal being used has changed (was "
|
||||
-- ++ display oldCabal ++ ", now "
|
||||
-- ++ display currentCabalId ++ ")."
|
||||
-- ++ badCompiler
|
||||
-- where
|
||||
-- badCompiler
|
||||
-- | oldCompiler == currentCompilerId = ""
|
||||
-- | otherwise =
|
||||
-- " Additionally the compiler is different (was "
|
||||
-- ++ display oldCompiler ++ ", now "
|
||||
-- ++ display currentCompilerId
|
||||
-- ++ ") which is probably the cause of the problem."
|
||||
|
||||
gmeDoc :: GhcModError -> Doc
|
||||
gmeDoc e = case e of
|
||||
@ -47,20 +90,83 @@ gmeDoc e = case e of
|
||||
text "Unknown error"
|
||||
GMEString msg ->
|
||||
text msg
|
||||
GMEIOException ioe ->
|
||||
text $ show ioe
|
||||
GMECabalConfigure msg ->
|
||||
text "cabal configure failed: " <> gmeDoc msg
|
||||
text "Configuring cabal project failed: " <> gmeDoc msg
|
||||
GMECabalFlags msg ->
|
||||
text "retrieval of the cabal configuration flags failed: " <> gmeDoc msg
|
||||
GMEProcess cmd msg ->
|
||||
text ("launching operating system process `"++unwords cmd++"` failed: ")
|
||||
<> gmeDoc msg
|
||||
text "Retrieval of the cabal configuration flags failed: " <> gmeDoc msg
|
||||
GMECabalComponent cn ->
|
||||
text "Cabal component " <> quotes (gmComponentNameDoc cn)
|
||||
<> text " could not be found."
|
||||
GMECabalCompAssignment ctx ->
|
||||
text "Could not find a consistent component assignment for modules:" $$
|
||||
(nest 4 $ foldr ($+$) empty $ map ctxDoc ctx) $$
|
||||
text "" $$
|
||||
(if all (Set.null . snd) ctx
|
||||
then noComponentSuggestions
|
||||
else empty) $$
|
||||
text "- To find out which components ghc-mod knows about try:" $$
|
||||
nest 4 (backticks $ text "ghc-mod debug")
|
||||
|
||||
where
|
||||
noComponentSuggestions =
|
||||
text "- Are some of these modules part of a test and or benchmark?\
|
||||
\ Try enabling them:" $$
|
||||
nest 4 (backticks $ text "cabal configure --enable-tests [--enable-benchmarks]")
|
||||
|
||||
backticks d = char '`' <> d <> char '`'
|
||||
ctxDoc = moduleDoc *** compsDoc
|
||||
>>> first (<> colon) >>> uncurry (flip hang 4)
|
||||
|
||||
moduleDoc (Left fn) =
|
||||
text "File " <> quotes (text fn)
|
||||
moduleDoc (Right mdl) =
|
||||
text "Module " <> quotes (text $ moduleNameString mdl)
|
||||
|
||||
compsDoc sc | Set.null sc = text "has no known components"
|
||||
compsDoc sc = fsep $ punctuate comma $
|
||||
map gmComponentNameDoc $ Set.toList sc
|
||||
|
||||
GMEProcess cmd args emsg -> let c = showCommandForUser cmd args in
|
||||
case emsg of
|
||||
Right err ->
|
||||
text (printf "Launching system command `%s` failed: " c)
|
||||
<> gmeDoc err
|
||||
Left (_out, _err, rv) -> text $
|
||||
printf "Launching system command `%s` failed (exited with %d)" c rv
|
||||
GMENoCabalFile ->
|
||||
text "No cabal file found."
|
||||
GMETooManyCabalFiles cfs ->
|
||||
text $ "Multiple cabal files found. Possible cabal files: \""
|
||||
++ intercalate "\", \"" cfs ++"\"."
|
||||
GMECabalStateFile csfe ->
|
||||
gmCsfeDoc csfe
|
||||
|
||||
ghcExceptionDoc :: GhcException -> Doc
|
||||
ghcExceptionDoc e@(CmdLineError _) =
|
||||
text $ "<command line>: " ++ showGhcException e ""
|
||||
ghcExceptionDoc (UsageError str) = strDoc str
|
||||
ghcExceptionDoc (Panic msg) = vcat $ map text $ lines $ printf "\
|
||||
\GHC panic! (the 'impossible' happened)\n\
|
||||
\ ghc-mod version %s\n\
|
||||
\ GHC library version %s for %s:\n\
|
||||
\ %s\n\
|
||||
\\n\
|
||||
\Please report this as a bug: %s\n"
|
||||
gmVer ghcVer platform msg url
|
||||
where
|
||||
gmVer = showVersion version
|
||||
ghcVer = cProjectVersion
|
||||
platform = cHostPlatformString
|
||||
url = "https://github.com/kazu-yamamoto/ghc-mod/issues" :: String
|
||||
|
||||
ghcExceptionDoc e = text $ showGhcException e ""
|
||||
|
||||
|
||||
liftMaybe :: MonadError e m => e -> m (Maybe a) -> m a
|
||||
liftMaybe e action = maybe (throwError e) return =<< action
|
||||
|
||||
overrideError :: MonadError e m => e -> m a -> m a
|
||||
overrideError e action = modifyError (const e) action
|
||||
|
||||
modifyError :: MonadError e m => (e -> e) -> m a -> m a
|
||||
modifyError f action = action `catchError` \e -> throwError $ f e
|
||||
@ -69,6 +175,24 @@ infixr 0 `modifyError'`
|
||||
modifyError' :: MonadError e m => m a -> (e -> e) -> m a
|
||||
modifyError' = flip modifyError
|
||||
|
||||
|
||||
modifyGmError :: (MonadIO m, ExceptionMonad m)
|
||||
=> (GhcModError -> GhcModError) -> m a -> m a
|
||||
modifyGmError f a = gcatch a $ \(ex :: GhcModError) -> liftIO $ throwIO (f ex)
|
||||
|
||||
tryFix :: MonadError e m => m a -> (e -> m ()) -> m a
|
||||
tryFix action fix = do
|
||||
action `catchError` \e -> fix e >> action
|
||||
tryFix action f = do
|
||||
action `catchError` \e -> f e >> action
|
||||
|
||||
data GHandler m a = forall e . Exception e => GHandler (e -> m a)
|
||||
|
||||
gcatches :: (MonadIO m, ExceptionMonad m) => m a -> [GHandler m a] -> m a
|
||||
gcatches io handlers = io `gcatch` gcatchesHandler handlers
|
||||
|
||||
gcatchesHandler :: (MonadIO m, ExceptionMonad m)
|
||||
=> [GHandler m a] -> SomeException -> m a
|
||||
gcatchesHandler handlers e = foldr tryHandler (liftIO $ throw e) handlers
|
||||
where tryHandler (GHandler handler) res
|
||||
= case fromException e of
|
||||
Just e' -> handler e'
|
||||
Nothing -> res
|
||||
|
@ -11,7 +11,8 @@ import Data.Char (isSymbol)
|
||||
import Data.Function (on)
|
||||
import Data.List (find, nub, sortBy)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (isJust, catMaybes)
|
||||
import Data.Maybe (catMaybes)
|
||||
import Text.PrettyPrint (($$), text, nest)
|
||||
import Exception (ghandle, SomeException(..))
|
||||
import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags,
|
||||
SrcSpan, Type, GenLocated(L))
|
||||
@ -19,8 +20,12 @@ import qualified GHC as G
|
||||
import qualified Name as G
|
||||
import qualified Language.Haskell.GhcMod.Gap as Gap
|
||||
import Language.Haskell.GhcMod.Convert
|
||||
import Language.Haskell.GhcMod.DynFlags
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.SrcUtils
|
||||
import Language.Haskell.GhcMod.Logging (gmLog)
|
||||
import Language.Haskell.GhcMod.Pretty (showDoc)
|
||||
import Language.Haskell.GhcMod.Doc
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Outputable (PprStyle)
|
||||
import qualified Type as Ty
|
||||
@ -31,6 +36,10 @@ import qualified HsPat as Ty
|
||||
import qualified Language.Haskell.Exts.Annotated as HE
|
||||
import Djinn.GHC
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 710
|
||||
import GHC (unLoc)
|
||||
#endif
|
||||
|
||||
----------------------------------------------------------------
|
||||
-- INTIAL CODE FROM FUNCTION OR INSTANCE SIGNATURE
|
||||
----------------------------------------------------------------
|
||||
@ -62,22 +71,27 @@ sig :: IOish m
|
||||
-> Int -- ^ Line number.
|
||||
-> Int -- ^ Column number.
|
||||
-> GhcModT m String
|
||||
sig file lineNo colNo = ghandle handler body
|
||||
where
|
||||
body = inModuleContext file $ \dflag style -> do
|
||||
sig file lineNo colNo =
|
||||
runGmlT' [Left file] deferErrors $ ghandle fallback $ do
|
||||
opt <- options
|
||||
style <- getStyle
|
||||
dflag <- G.getSessionDynFlags
|
||||
modSum <- Gap.fileModSummary file
|
||||
whenFound opt (getSignature modSum lineNo colNo) $ \s -> case s of
|
||||
whenFound opt (getSignature modSum lineNo colNo) $ \s ->
|
||||
case s of
|
||||
Signature loc names ty ->
|
||||
("function", fourInts loc, map (initialBody dflag style ty) names)
|
||||
|
||||
InstanceDecl loc cls ->
|
||||
("instance", fourInts loc, map (\x -> initialBody dflag style (G.idType x) x)
|
||||
(Ty.classMethods cls))
|
||||
let body x = initialBody dflag style (G.idType x) x
|
||||
in ("instance", fourInts loc, body `map` Ty.classMethods cls)
|
||||
|
||||
TyFamDecl loc name flavour vars ->
|
||||
let (rTy, initial) = initialTyFamString flavour
|
||||
in (rTy, fourInts loc, [initial ++ initialFamBody dflag style name vars])
|
||||
|
||||
handler (SomeException _) = do
|
||||
body = initialFamBody dflag style name vars
|
||||
in (rTy, fourInts loc, [initial ++ body])
|
||||
where
|
||||
fallback (SomeException _) = do
|
||||
opt <- options
|
||||
-- Code cannot be parsed by ghc module
|
||||
-- Fallback: try to get information via haskell-src-exts
|
||||
@ -97,7 +111,11 @@ getSignature modSum lineNo colNo = do
|
||||
p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum
|
||||
-- Inspect the parse tree to find the signature
|
||||
case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsDecl G.RdrName] of
|
||||
#if __GLASGOW_HASKELL__ >= 710
|
||||
[L loc (G.SigD (Ty.TypeSig names (L _ ty) _))] ->
|
||||
#else
|
||||
[L loc (G.SigD (Ty.TypeSig names (L _ ty)))] ->
|
||||
#endif
|
||||
-- We found a type signature
|
||||
return $ Just $ Signature loc (map G.unLoc names) ty
|
||||
[L _ (G.InstD _)] -> do
|
||||
@ -125,7 +143,12 @@ getSignature modSum lineNo colNo = do
|
||||
G.TypeFamily -> Open
|
||||
G.DataFamily -> Data
|
||||
#endif
|
||||
#if __GLASGOW_HASKELL__ >= 706
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 710
|
||||
getTyFamVarName x = case x of
|
||||
L _ (G.UserTyVar n) -> n
|
||||
L _ (G.KindedTyVar (G.L _ n) _) -> n
|
||||
#elif __GLASGOW_HASKELL__ >= 706
|
||||
getTyFamVarName x = case x of
|
||||
L _ (G.UserTyVar n) -> n
|
||||
L _ (G.KindedTyVar n _) -> n
|
||||
@ -144,7 +167,8 @@ getSignature modSum lineNo colNo = do
|
||||
return $ InstanceDecl loc cls
|
||||
|
||||
-- Get signature from haskell-src-exts
|
||||
getSignatureFromHE :: GhcMonad m => FilePath -> Int -> Int -> m (Maybe HESigInfo)
|
||||
getSignatureFromHE :: (MonadIO m, GhcMonad m) =>
|
||||
FilePath -> Int -> Int -> m (Maybe HESigInfo)
|
||||
getSignatureFromHE file lineNo colNo = do
|
||||
presult <- liftIO $ HE.parseFile file
|
||||
return $ case presult of
|
||||
@ -220,9 +244,11 @@ initialHead1 :: String -> [FnArg] -> [String] -> String
|
||||
initialHead1 fname args elts =
|
||||
case initialBodyArgs1 args elts of
|
||||
[] -> fname
|
||||
arglist -> if isSymbolName fname
|
||||
then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)
|
||||
else fname ++ " " ++ unwords arglist
|
||||
arglist
|
||||
| isSymbolName fname ->
|
||||
head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)
|
||||
| otherwise ->
|
||||
fname ++ " " ++ unwords arglist
|
||||
|
||||
initialBodyArgs1 :: [FnArg] -> [String] -> [String]
|
||||
initialBodyArgs1 args elts = take (length args) elts
|
||||
@ -238,12 +264,24 @@ class FnArgsInfo ty name | ty -> name, name -> ty where
|
||||
|
||||
instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where
|
||||
getFnName dflag style name = showOccName dflag style $ Gap.occName name
|
||||
getFnArgs (G.HsForAllTy _ _ _ (L _ iTy)) = getFnArgs iTy
|
||||
#if __GLASGOW_HASKELL__ >= 710
|
||||
getFnArgs (G.HsForAllTy _ _ _ _ (L _ iTy))
|
||||
#else
|
||||
getFnArgs (G.HsForAllTy _ _ _ (L _ iTy))
|
||||
#endif
|
||||
= getFnArgs iTy
|
||||
|
||||
getFnArgs (G.HsParTy (L _ iTy)) = getFnArgs iTy
|
||||
getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) =
|
||||
(if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy
|
||||
where fnarg ty = case ty of
|
||||
(G.HsForAllTy _ _ _ (L _ iTy)) -> fnarg iTy
|
||||
#if __GLASGOW_HASKELL__ >= 710
|
||||
(G.HsForAllTy _ _ _ _ (L _ iTy)) ->
|
||||
#else
|
||||
(G.HsForAllTy _ _ _ (L _ iTy)) ->
|
||||
#endif
|
||||
fnarg iTy
|
||||
|
||||
(G.HsParTy (L _ iTy)) -> fnarg iTy
|
||||
(G.HsFunTy _ _) -> True
|
||||
_ -> False
|
||||
@ -301,10 +339,12 @@ refine :: IOish m
|
||||
-> Int -- ^ Column number.
|
||||
-> Expression -- ^ A Haskell expression.
|
||||
-> GhcModT m String
|
||||
refine file lineNo colNo expr = ghandle handler body
|
||||
where
|
||||
body = inModuleContext file $ \dflag style -> do
|
||||
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
|
||||
@ -316,33 +356,44 @@ refine file lineNo colNo expr = ghandle handler body
|
||||
diffArgs' = length eArgs - length rArgs
|
||||
diffArgs = if diffArgs' < 0 then 0 else diffArgs'
|
||||
iArgs = take diffArgs eArgs
|
||||
text = initialHead1 expr iArgs (infinitePrefixSupply name)
|
||||
in (fourInts loc, doParen paren text)
|
||||
|
||||
handler (SomeException _) = emptyResult =<< options
|
||||
txt = initialHead1 expr iArgs (infinitePrefixSupply name)
|
||||
in (fourInts loc, doParen paren txt)
|
||||
where
|
||||
handler (SomeException ex) = do
|
||||
gmLog GmDebug "refining" $
|
||||
text "" $$ nest 4 (showDoc ex)
|
||||
emptyResult =<< options
|
||||
|
||||
-- Look for the variable in the specified position
|
||||
findVar :: GhcMonad m => DynFlags -> PprStyle
|
||||
-> G.TypecheckedModule -> G.TypecheckedSource
|
||||
-> Int -> Int -> m (Maybe (SrcSpan, String, Type, Bool))
|
||||
findVar
|
||||
:: GhcMonad m
|
||||
=> DynFlags
|
||||
-> PprStyle
|
||||
-> G.TypecheckedModule
|
||||
-> G.TypecheckedSource
|
||||
-> Int
|
||||
-> Int
|
||||
-> m (Maybe (SrcSpan, String, Type, Bool))
|
||||
findVar dflag style tcm tcs lineNo colNo =
|
||||
let lst = sortBy (cmp `on` G.getLoc) $
|
||||
listifySpans tcs (lineNo, colNo) :: [G.LHsExpr Id]
|
||||
in case lst of
|
||||
e@(L _ (G.HsVar i)):others ->
|
||||
do tyInfo <- Gap.getType tcm e
|
||||
let name = getFnName dflag style i
|
||||
if (name == "undefined" || head name == '_') && isJust tyInfo
|
||||
then let Just (s,t) = tyInfo
|
||||
b = case others of -- If inside an App, we need
|
||||
-- parenthesis
|
||||
[] -> False
|
||||
case lst of
|
||||
e@(L _ (G.HsVar i)):others -> do
|
||||
tyInfo <- Gap.getType tcm e
|
||||
case tyInfo of
|
||||
Just (s, typ)
|
||||
| name == "undefined" || head name == '_' ->
|
||||
return $ Just (s, name, typ, b)
|
||||
where
|
||||
name = getFnName dflag style i
|
||||
-- If inside an App, we need parenthesis
|
||||
b = case others of
|
||||
L _ (G.HsApp (L _ a1) (L _ a2)):_ ->
|
||||
isSearchedVar i a1 || isSearchedVar i a2
|
||||
_ -> False
|
||||
in return $ Just (s, name, t, b)
|
||||
else return Nothing
|
||||
_ -> return Nothing
|
||||
_ -> return Nothing
|
||||
where
|
||||
lst :: [G.LHsExpr Id]
|
||||
lst = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo)
|
||||
|
||||
infinitePrefixSupply :: String -> [String]
|
||||
infinitePrefixSupply "undefined" = repeat "undefined"
|
||||
@ -366,10 +417,11 @@ auto :: IOish m
|
||||
-> Int -- ^ Line number.
|
||||
-> Int -- ^ Column number.
|
||||
-> GhcModT m String
|
||||
auto file lineNo colNo = ghandle handler body
|
||||
where
|
||||
body = inModuleContext file $ \dflag style -> do
|
||||
auto file lineNo colNo =
|
||||
ghandle handler $ runGmlT' [Left file] deferErrors $ do
|
||||
opt <- options
|
||||
style <- getStyle
|
||||
dflag <- G.getSessionDynFlags
|
||||
modSum <- Gap.fileModSummary file
|
||||
p <- G.parseModule modSum
|
||||
tcm@TypecheckedModule {
|
||||
@ -395,8 +447,11 @@ auto file lineNo colNo = ghandle handler body
|
||||
djinns <- djinn True (Just minfo) env rty (Max 10) 100000
|
||||
return ( fourInts loc
|
||||
, map (doParen paren) $ nub (djinnsEmpty ++ djinns))
|
||||
|
||||
handler (SomeException _) = emptyResult =<< options
|
||||
where
|
||||
handler (SomeException ex) = do
|
||||
gmLog GmDebug "auto-refining" $
|
||||
text "" $$ nest 4 (showDoc ex)
|
||||
emptyResult =<< options
|
||||
|
||||
-- Functions we do not want in completions
|
||||
notWantedFuns :: [String]
|
||||
@ -443,7 +498,11 @@ getPatsForVariable tcs (lineNo, colNo) =
|
||||
#else
|
||||
:: [G.LMatch Id]
|
||||
#endif
|
||||
#if __GLASGOW_HASKELL__ >= 710
|
||||
(L _ (G.Match _ pats _ _):_) = m
|
||||
#else
|
||||
(L _ (G.Match pats _ _):_) = m
|
||||
#endif
|
||||
in (funId, pats)
|
||||
_ -> (error "This should never happen", [])
|
||||
|
||||
@ -478,7 +537,13 @@ getBindingsForRecPat (Ty.PrefixCon args) =
|
||||
getBindingsForRecPat (Ty.InfixCon (L _ a1) (L _ a2)) =
|
||||
M.union (getBindingsForPat a1) (getBindingsForPat a2)
|
||||
getBindingsForRecPat (Ty.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) =
|
||||
getBindingsForRecFields fields
|
||||
where getBindingsForRecFields [] = M.empty
|
||||
getBindingsForRecFields (map unLoc' fields)
|
||||
where
|
||||
#if __GLASGOW_HASKELL__ >= 710
|
||||
unLoc' = unLoc
|
||||
#else
|
||||
unLoc' = id
|
||||
#endif
|
||||
getBindingsForRecFields [] = M.empty
|
||||
getBindingsForRecFields (Ty.HsRecField {Ty.hsRecFieldArg = (L _ a)}:fs) =
|
||||
M.union (getBindingsForPat a) (getBindingsForRecFields fs)
|
||||
|
@ -1,9 +1,8 @@
|
||||
{-# LANGUAGE CPP, BangPatterns #-}
|
||||
{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse #-}
|
||||
|
||||
module Language.Haskell.GhcMod.Find
|
||||
#ifndef SPEC
|
||||
(
|
||||
Symbol
|
||||
( Symbol
|
||||
, SymbolDb
|
||||
, loadSymbolDb
|
||||
, lookupSymbol
|
||||
@ -15,65 +14,51 @@ module Language.Haskell.GhcMod.Find
|
||||
#endif
|
||||
where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Applicative
|
||||
import Control.Monad (when, void)
|
||||
import Data.Function (on)
|
||||
import Data.List (groupBy, sort)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified GHC as G
|
||||
import Language.Haskell.GhcMod.Convert
|
||||
import Language.Haskell.GhcMod.Gap (listVisibleModules)
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.PathsAndFiles
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Utils
|
||||
import Language.Haskell.GhcMod.PathsAndFiles
|
||||
import Language.Haskell.GhcMod.World (timedPackageCaches)
|
||||
import Language.Haskell.GhcMod.Output
|
||||
import Name (getOccString)
|
||||
import Module (moduleName)
|
||||
import System.Directory (doesFileExist, getModificationTime)
|
||||
import System.FilePath ((</>), takeDirectory)
|
||||
import System.FilePath ((</>))
|
||||
import System.IO
|
||||
import Prelude
|
||||
|
||||
#ifndef MIN_VERSION_containers
|
||||
#define MIN_VERSION_containers(x,y,z) 1
|
||||
#endif
|
||||
|
||||
#if MIN_VERSION_containers(0,5,0)
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
#else
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as M
|
||||
#endif
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Type of function and operation names.
|
||||
type Symbol = String
|
||||
-- | Database from 'Symbol' to \['ModuleString'\].
|
||||
data SymbolDb = SymbolDb {
|
||||
table :: Map Symbol [ModuleString]
|
||||
, packageCachePath :: FilePath
|
||||
data SymbolDb = SymbolDb
|
||||
{ table :: Map Symbol [ModuleString]
|
||||
, symbolDbCachePath :: FilePath
|
||||
} deriving (Show)
|
||||
|
||||
isOutdated :: SymbolDb -> IO Bool
|
||||
isOutdated db = symbolDbCachePath db `isOlderThan` packageCachePath db
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | When introducing incompatible changes to the 'symbolCache' file format
|
||||
-- increment this version number.
|
||||
symbolCacheVersion :: Integer
|
||||
symbolCacheVersion = 0
|
||||
|
||||
-- | Filename of the symbol table cache file.
|
||||
symbolCache :: String
|
||||
symbolCache = "ghc-mod-"++ show symbolCacheVersion ++".cache"
|
||||
isOutdated :: IOish m => SymbolDb -> GhcModT m Bool
|
||||
isOutdated db =
|
||||
(liftIO . isOlderThan (symbolDbCachePath db)) =<< timedPackageCaches
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]
|
||||
-- which will be concatenated. 'loadSymbolDb' is called internally.
|
||||
findSymbol :: IOish m => Symbol -> GhcModT m String
|
||||
findSymbol sym = loadSymbolDb >>= lookupSymbol sym
|
||||
findSymbol sym = do
|
||||
tmpdir <- cradleTempDir <$> cradle
|
||||
loadSymbolDb tmpdir >>= lookupSymbol sym
|
||||
|
||||
-- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]
|
||||
-- which will be concatenated.
|
||||
@ -81,25 +66,25 @@ lookupSymbol :: IOish m => Symbol -> SymbolDb -> GhcModT m String
|
||||
lookupSymbol sym db = convert' $ lookupSym sym db
|
||||
|
||||
lookupSym :: Symbol -> SymbolDb -> [ModuleString]
|
||||
lookupSym sym db = fromMaybe [] $ M.lookup sym $ table db
|
||||
lookupSym sym db = M.findWithDefault [] sym $ table db
|
||||
|
||||
---------------------------------------------------------------
|
||||
|
||||
-- | Loading a file and creates 'SymbolDb'.
|
||||
loadSymbolDb :: IOish m => GhcModT m SymbolDb
|
||||
loadSymbolDb = do
|
||||
loadSymbolDb :: IOish m => FilePath -> GhcModT m SymbolDb
|
||||
loadSymbolDb dir = do
|
||||
ghcMod <- liftIO ghcModExecutable
|
||||
tmpdir <- cradleTempDir <$> cradle
|
||||
file <- chop <$> readProcess' ghcMod ["dumpsym", tmpdir]
|
||||
readProc <- gmReadProcess
|
||||
file <- liftIO $ chop <$> readProc ghcMod ["dumpsym", dir] ""
|
||||
!db <- M.fromAscList . map conv . lines <$> liftIO (readFile file)
|
||||
return $ SymbolDb {
|
||||
table = db
|
||||
, packageCachePath = takeDirectory file </> packageCache
|
||||
return $ SymbolDb
|
||||
{ table = db
|
||||
, symbolDbCachePath = file
|
||||
}
|
||||
where
|
||||
conv :: String -> (Symbol, [ModuleString])
|
||||
conv = read
|
||||
chop :: String -> String
|
||||
chop "" = ""
|
||||
chop xs = init xs
|
||||
|
||||
@ -112,12 +97,13 @@ loadSymbolDb = do
|
||||
|
||||
dumpSymbol :: IOish m => FilePath -> GhcModT m String
|
||||
dumpSymbol dir = do
|
||||
let cache = dir </> symbolCache
|
||||
pkgdb = dir </> packageCache
|
||||
|
||||
create <- liftIO $ cache `isOlderThan` pkgdb
|
||||
when create $ (liftIO . writeSymbolCache cache) =<< getSymbolTable
|
||||
create <- (liftIO . isOlderThan cache) =<< timedPackageCaches
|
||||
runGmPkgGhc $ do
|
||||
when create $
|
||||
liftIO . writeSymbolCache cache =<< getGlobalSymbolTable
|
||||
return $ unlines [cache]
|
||||
where
|
||||
cache = dir </> symbolCacheFile
|
||||
|
||||
writeSymbolCache :: FilePath
|
||||
-> [(Symbol, [ModuleString])]
|
||||
@ -126,37 +112,34 @@ writeSymbolCache cache sm =
|
||||
void . withFile cache WriteMode $ \hdl ->
|
||||
mapM (hPrint hdl) sm
|
||||
|
||||
isOlderThan :: FilePath -> FilePath -> IO Bool
|
||||
isOlderThan cache file = do
|
||||
-- | Check whether given file is older than any file from the given set.
|
||||
-- Returns True if given file does not exist.
|
||||
isOlderThan :: FilePath -> [TimedFile] -> IO Bool
|
||||
isOlderThan cache files = do
|
||||
exist <- doesFileExist cache
|
||||
if not exist then
|
||||
return True
|
||||
if not exist
|
||||
then return True
|
||||
else do
|
||||
tCache <- getModificationTime cache
|
||||
tFile <- getModificationTime file
|
||||
return $ tCache <= tFile -- including equal just in case
|
||||
|
||||
-- | Browsing all functions in all system/user modules.
|
||||
getSymbolTable :: IOish m => GhcModT m [(Symbol,[ModuleString])]
|
||||
getSymbolTable = do
|
||||
ghcModules <- G.packageDbModules True
|
||||
moduleInfos <- mapM G.getModuleInfo ghcModules
|
||||
let modules = do
|
||||
m <- ghcModules
|
||||
let moduleName = G.moduleNameString $ G.moduleName m
|
||||
-- modulePkg = G.packageIdString $ G.modulePackageId m
|
||||
return moduleName
|
||||
return $ any (tCache <=) $ map tfTime files -- including equal just in case
|
||||
|
||||
-- | Browsing all functions in all system modules.
|
||||
getGlobalSymbolTable :: LightGhc [(Symbol, [ModuleString])]
|
||||
getGlobalSymbolTable = do
|
||||
df <- G.getSessionDynFlags
|
||||
let mods = listVisibleModules df
|
||||
moduleInfos <- mapM G.getModuleInfo mods
|
||||
return $ collectModules
|
||||
$ extractBindings `concatMap` (moduleInfos `zip` modules)
|
||||
$ extractBindings `concatMap` (moduleInfos `zip` mods)
|
||||
|
||||
extractBindings :: (Maybe G.ModuleInfo, ModuleString)
|
||||
extractBindings :: (Maybe G.ModuleInfo, G.Module)
|
||||
-> [(Symbol, ModuleString)]
|
||||
extractBindings (Nothing, _) = []
|
||||
extractBindings (Just inf,mdlname) =
|
||||
map (\name -> (getOccString name, mdlname)) names
|
||||
extractBindings (Just inf, mdl) =
|
||||
map (\name -> (getOccString name, modStr)) names
|
||||
where
|
||||
names = G.modInfoExports inf
|
||||
modStr = ModuleString $ moduleNameString $ moduleName mdl
|
||||
|
||||
collectModules :: [(Symbol, ModuleString)]
|
||||
-> [(Symbol, [ModuleString])]
|
||||
|
@ -1,86 +0,0 @@
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Language.Haskell.GhcMod.GHCApi (
|
||||
ghcPkgDb
|
||||
, package
|
||||
, modules
|
||||
, findModule
|
||||
, moduleInfo
|
||||
, localModuleInfo
|
||||
, bindings
|
||||
) where
|
||||
|
||||
import Language.Haskell.GhcMod.GhcPkg
|
||||
import Language.Haskell.GhcMod.Monad (GhcModT)
|
||||
import Language.Haskell.GhcMod.Target (setTargetFiles)
|
||||
import Language.Haskell.GhcMod.Types
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Distribution.Package (InstalledPackageId(..))
|
||||
import qualified Data.Map as M
|
||||
import GHC (DynFlags(..))
|
||||
import qualified GHC as G
|
||||
import GhcMonad
|
||||
import qualified Packages as G
|
||||
import qualified Module as G
|
||||
import qualified OccName as G
|
||||
|
||||
----------------------------------------------------------------
|
||||
-- get Packages,Modules,Bindings
|
||||
|
||||
ghcPkgDb :: GhcMonad m => m PkgDb
|
||||
ghcPkgDb = M.fromList <$>
|
||||
maybe [] (map toKv . filterInternal) <$> pkgDatabase <$> G.getSessionDynFlags
|
||||
where
|
||||
toKv pkg = (fromInstalledPackageId $ G.installedPackageId pkg, pkg)
|
||||
filterInternal =
|
||||
filter ((/= InstalledPackageId "builtin_rts") . G.installedPackageId)
|
||||
|
||||
package :: G.PackageConfig -> Package
|
||||
package = fromInstalledPackageId . G.installedPackageId
|
||||
|
||||
modules :: G.PackageConfig -> [ModuleString]
|
||||
modules = map G.moduleNameString . G.exposedModules
|
||||
|
||||
findModule :: ModuleString -> PkgDb -> [Package]
|
||||
findModule m db = M.elems $ package `M.map` (containsModule `M.filter` db)
|
||||
where
|
||||
containsModule :: G.PackageConfig -> Bool
|
||||
containsModule pkgConf =
|
||||
G.mkModuleName m `elem` G.exposedModules pkgConf
|
||||
|
||||
|
||||
ghcPkgId :: Package -> G.PackageId
|
||||
ghcPkgId (name,_,_) =
|
||||
-- TODO: Adding the package version too breaks 'findModule' for some reason
|
||||
-- this isn't a big deal since in the common case where we're in a cabal
|
||||
-- project we just use cabal's view of package dependencies anyways so we're
|
||||
-- guaranteed to only have one version of each package exposed. However when
|
||||
-- we're operating without a cabal project this will probaly cause trouble.
|
||||
G.stringToPackageId name
|
||||
|
||||
type Binding = String
|
||||
|
||||
-- | @moduleInfo mpkg module@. @mpkg@ should be 'Nothing' iff. moduleInfo
|
||||
-- should look for @module@ in the working directory.
|
||||
--
|
||||
-- To map a 'ModuleString' to a package see 'findModule'
|
||||
moduleInfo :: IOish m
|
||||
=> Maybe Package
|
||||
-> ModuleString
|
||||
-> GhcModT m (Maybe G.ModuleInfo)
|
||||
moduleInfo mpkg mdl = do
|
||||
let mdlName = G.mkModuleName mdl
|
||||
mfsPkgId = G.packageIdFS . ghcPkgId <$> mpkg
|
||||
loadLocalModule
|
||||
G.findModule mdlName mfsPkgId >>= G.getModuleInfo
|
||||
where
|
||||
loadLocalModule = case mpkg of
|
||||
Just _ -> return ()
|
||||
Nothing -> setTargetFiles [mdl]
|
||||
|
||||
localModuleInfo :: IOish m => ModuleString -> GhcModT m (Maybe G.ModuleInfo)
|
||||
localModuleInfo mdl = moduleInfo Nothing mdl
|
||||
|
||||
bindings :: G.ModuleInfo -> [Binding]
|
||||
bindings minfo = map (G.occNameString . G.getOccName) $ G.modInfoExports minfo
|
@ -1,23 +0,0 @@
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Language.Haskell.GhcMod.GHCChoice where
|
||||
|
||||
import Control.Exception (IOException)
|
||||
import CoreMonad (liftIO)
|
||||
import qualified Exception as GE
|
||||
import GHC (GhcMonad)
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Try the left 'Ghc' action. If 'IOException' occurs, try
|
||||
-- the right 'Ghc' action.
|
||||
(||>) :: GhcMonad m => m a -> m a -> m a
|
||||
x ||> y = x `GE.gcatch` (\(_ :: IOException) -> y)
|
||||
|
||||
-- | Go to the next 'Ghc' monad by throwing 'AltGhcgoNext'.
|
||||
goNext :: GhcMonad m => m a
|
||||
goNext = liftIO . GE.throwIO $ userError "goNext"
|
||||
|
||||
-- | Run any one 'Ghc' monad.
|
||||
runAnyOne :: GhcMonad m => [m a] -> m a
|
||||
runAnyOne = foldr (||>) goNext
|
@ -13,7 +13,6 @@ module Language.Haskell.GhcMod.Gap (
|
||||
, showSeverityCaption
|
||||
, setCabalPkg
|
||||
, setHideAllPackages
|
||||
, addPackageFlags
|
||||
, setDeferTypeErrors
|
||||
, setWarnTypedHoles
|
||||
, setDumpSplices
|
||||
@ -33,14 +32,15 @@ module Language.Haskell.GhcMod.Gap (
|
||||
, fileModSummary
|
||||
, WarnFlags
|
||||
, emptyWarnFlags
|
||||
, benchmarkBuildInfo
|
||||
, benchmarkTargets
|
||||
, toModuleString
|
||||
, GLMatch
|
||||
, GLMatchI
|
||||
, getClass
|
||||
, occName
|
||||
, setFlags
|
||||
, listVisibleModuleNames
|
||||
, listVisibleModules
|
||||
, lookupModulePackageInAllPackages
|
||||
, Language.Haskell.GhcMod.Gap.isSynTyCon
|
||||
, parseModuleHeader
|
||||
) where
|
||||
|
||||
import Control.Applicative hiding (empty)
|
||||
@ -49,15 +49,15 @@ import CoreSyn (CoreExpr)
|
||||
import Data.List (intersperse)
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Data.Traversable hiding (mapM)
|
||||
import DataCon (dataConRepType)
|
||||
import Desugar (deSugarExpr)
|
||||
import DynFlags
|
||||
import ErrUtils
|
||||
import Exception
|
||||
import FastString
|
||||
import GhcMonad
|
||||
import HscTypes
|
||||
import Language.Haskell.GhcMod.GHCChoice
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import NameSet
|
||||
import OccName
|
||||
import Outputable
|
||||
@ -65,8 +65,8 @@ import PprTyThing
|
||||
import StringBuffer
|
||||
import TcType
|
||||
import Var (varType)
|
||||
import System.Directory
|
||||
|
||||
import qualified Distribution.PackageDescription as P
|
||||
import qualified InstEnv
|
||||
import qualified Pretty
|
||||
import qualified StringBuffer as SB
|
||||
@ -88,11 +88,24 @@ import Data.Convertible
|
||||
import RdrName (rdrNameOcc)
|
||||
#endif
|
||||
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
import UniqFM (eltsUFM)
|
||||
import Module
|
||||
#endif
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 704
|
||||
import qualified Data.IntSet as I (IntSet, empty)
|
||||
import qualified Distribution.ModuleName as M (ModuleName,toFilePath)
|
||||
#endif
|
||||
|
||||
import Bag
|
||||
import Lexer as L
|
||||
import Parser
|
||||
import SrcLoc
|
||||
import Packages
|
||||
|
||||
import Language.Haskell.GhcMod.Types (Expression(..))
|
||||
import Prelude
|
||||
|
||||
----------------------------------------------------------------
|
||||
----------------------------------------------------------------
|
||||
--
|
||||
@ -173,7 +186,11 @@ toStringBuffer = liftIO . stringToStringBuffer . unlines
|
||||
----------------------------------------------------------------
|
||||
|
||||
fOptions :: [String]
|
||||
#if __GLASGOW_HASKELL__ >= 704
|
||||
#if __GLASGOW_HASKELL__ >= 710
|
||||
fOptions = [option | (FlagSpec option _ _ _) <- fFlags]
|
||||
++ [option | (FlagSpec option _ _ _) <- fWarningFlags]
|
||||
++ [option | (FlagSpec option _ _ _) <- fLangFlags]
|
||||
#elif __GLASGOW_HASKELL__ >= 704
|
||||
fOptions = [option | (option,_,_) <- fFlags]
|
||||
++ [option | (option,_,_) <- fWarningFlags]
|
||||
++ [option | (option,_,_) <- fLangFlags]
|
||||
@ -187,9 +204,11 @@ fOptions = [option | (option,_,_,_) <- fFlags]
|
||||
----------------------------------------------------------------
|
||||
|
||||
fileModSummary :: GhcMonad m => FilePath -> m ModSummary
|
||||
fileModSummary file = do
|
||||
fileModSummary file' = do
|
||||
mss <- getModuleGraph
|
||||
let [ms] = filter (\m -> ml_hs_file (ms_location m) == Just file) mss
|
||||
file <- liftIO $ canonicalizePath file'
|
||||
[ms] <- liftIO $ flip filterM mss $ \m ->
|
||||
(Just file==) <$> canonicalizePath `traverse` ml_hs_file (ms_location m)
|
||||
return ms
|
||||
|
||||
withContext :: GhcMonad m => m a -> m a
|
||||
@ -202,26 +221,31 @@ withContext action = gbracket setup teardown body
|
||||
action
|
||||
topImports = do
|
||||
mss <- getModuleGraph
|
||||
ms <- map modName <$> filterM isTop mss
|
||||
mns <- map modName <$> filterM isTop mss
|
||||
let ii = map IIModule mns
|
||||
#if __GLASGOW_HASKELL__ >= 704
|
||||
return ms
|
||||
return ii
|
||||
#else
|
||||
return (ms,[])
|
||||
return (ii,[])
|
||||
#endif
|
||||
isTop mos = lookupMod mos ||> returnFalse
|
||||
lookupMod mos = lookupModule (ms_mod_name mos) Nothing >> return True
|
||||
returnFalse = return False
|
||||
#if __GLASGOW_HASKELL__ >= 706
|
||||
modName = IIModule . moduleName . ms_mod
|
||||
modName = moduleName . ms_mod
|
||||
setCtx = setContext
|
||||
#elif __GLASGOW_HASKELL__ >= 704
|
||||
modName = IIModule . ms_mod
|
||||
modName = ms_mod
|
||||
setCtx = setContext
|
||||
#else
|
||||
modName = ms_mod
|
||||
setCtx = uncurry setContext
|
||||
#endif
|
||||
|
||||
-- | Try the left action, if an IOException occurs try the right action.
|
||||
(||>) :: ExceptionMonad m => m a -> m a -> m a
|
||||
x ||> y = x `gcatch` (\(_ :: IOException) -> y)
|
||||
|
||||
showSeverityCaption :: Severity -> String
|
||||
#if __GLASGOW_HASKELL__ >= 706
|
||||
showSeverityCaption SevWarning = "Warning: "
|
||||
@ -249,12 +273,6 @@ setHideAllPackages df = gopt_set df Opt_HideAllPackages
|
||||
setHideAllPackages df = dopt_set df Opt_HideAllPackages
|
||||
#endif
|
||||
|
||||
addPackageFlags :: [Package] -> DynFlags -> DynFlags
|
||||
addPackageFlags pkgs df =
|
||||
df { packageFlags = packageFlags df ++ expose `map` pkgs }
|
||||
where
|
||||
expose pkg = ExposePackageId $ showPkgId pkg
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
setDumpSplices :: DynFlags -> DynFlags
|
||||
@ -310,8 +328,8 @@ filterOutChildren get_thing xs
|
||||
where
|
||||
implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
|
||||
|
||||
infoThing :: GhcMonad m => String -> m SDoc
|
||||
infoThing str = do
|
||||
infoThing :: GhcMonad m => Expression -> m SDoc
|
||||
infoThing (Expression str) = do
|
||||
names <- parseName str
|
||||
#if __GLASGOW_HASKELL__ >= 708
|
||||
mb_stuffs <- mapM (getInfo False) names
|
||||
@ -413,29 +431,6 @@ emptyWarnFlags = []
|
||||
----------------------------------------------------------------
|
||||
----------------------------------------------------------------
|
||||
|
||||
benchmarkBuildInfo :: P.PackageDescription -> [P.BuildInfo]
|
||||
#if __GLASGOW_HASKELL__ >= 704
|
||||
benchmarkBuildInfo pd = map P.benchmarkBuildInfo $ P.benchmarks pd
|
||||
#else
|
||||
benchmarkBuildInfo pd = []
|
||||
#endif
|
||||
|
||||
benchmarkTargets :: P.PackageDescription -> [String]
|
||||
#if __GLASGOW_HASKELL__ >= 704
|
||||
benchmarkTargets pd = map toModuleString $ concatMap P.benchmarkModules $ P.benchmarks pd
|
||||
#else
|
||||
benchmarkTargets = []
|
||||
#endif
|
||||
|
||||
toModuleString :: M.ModuleName -> String
|
||||
toModuleString mn = fromFilePath $ M.toFilePath mn
|
||||
where
|
||||
fromFilePath :: FilePath -> String
|
||||
fromFilePath fp = map (\c -> if c=='/' then '.' else c) fp
|
||||
|
||||
----------------------------------------------------------------
|
||||
----------------------------------------------------------------
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 708
|
||||
type GLMatch = LMatch RdrName (LHsExpr RdrName)
|
||||
type GLMatchI = LMatch Id (LHsExpr Id)
|
||||
@ -445,7 +440,12 @@ type GLMatchI = LMatch Id
|
||||
#endif
|
||||
|
||||
getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan)
|
||||
#if __GLASGOW_HASKELL__ >= 708
|
||||
#if __GLASGOW_HASKELL__ >= 710
|
||||
-- Instance declarations of sort 'instance F (G a)'
|
||||
getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsForAllTy _ _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _))))}))] = Just (className, loc)
|
||||
-- Instance declarations of sort 'instance F G' (no variables)
|
||||
getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsAppTy (L _ (HsTyVar className)) _))}))] = Just (className, loc)
|
||||
#elif __GLASGOW_HASKELL__ >= 708
|
||||
-- Instance declarations of sort 'instance F (G a)'
|
||||
getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _))))}))] = Just (className, loc)
|
||||
-- Instance declarations of sort 'instance F G' (no variables)
|
||||
@ -464,12 +464,74 @@ occName :: RdrName -> OccName
|
||||
occName = rdrNameOcc
|
||||
#endif
|
||||
|
||||
----------------------------------------------------------------
|
||||
----------------------------------------------------------------
|
||||
|
||||
setFlags :: DynFlags -> DynFlags
|
||||
#if __GLASGOW_HASKELL__ >= 708
|
||||
setFlags df = df `gopt_unset` Opt_SpecConstr -- consume memory if -O2
|
||||
#else
|
||||
setFlags = id
|
||||
#if __GLASGOW_HASKELL__ < 710
|
||||
-- Copied from ghc/InteractiveUI.hs
|
||||
allExposedPackageConfigs :: DynFlags -> [PackageConfig]
|
||||
allExposedPackageConfigs df = filter exposed $ eltsUFM $ pkgIdMap $ pkgState df
|
||||
|
||||
allExposedModules :: DynFlags -> [ModuleName]
|
||||
allExposedModules df = concat $ map exposedModules $ allExposedPackageConfigs df
|
||||
|
||||
listVisibleModuleNames :: DynFlags -> [ModuleName]
|
||||
listVisibleModuleNames = allExposedModules
|
||||
#endif
|
||||
|
||||
lookupModulePackageInAllPackages ::
|
||||
DynFlags -> ModuleName -> [String]
|
||||
lookupModulePackageInAllPackages df mn =
|
||||
#if __GLASGOW_HASKELL__ >= 710
|
||||
unpackSPId . sourcePackageId . snd <$> lookupModuleInAllPackages df mn
|
||||
where
|
||||
unpackSPId (SourcePackageId fs) = unpackFS fs
|
||||
#else
|
||||
unpackPId . sourcePackageId . fst <$> lookupModuleInAllPackages df mn
|
||||
where
|
||||
unpackPId pid = packageIdString $ mkPackageId pid
|
||||
-- n ++ "-" ++ showVersion v
|
||||
#endif
|
||||
|
||||
listVisibleModules :: DynFlags -> [GHC.Module]
|
||||
listVisibleModules df = let
|
||||
#if __GLASGOW_HASKELL__ >= 710
|
||||
modNames = listVisibleModuleNames df
|
||||
mods = [ m | mn <- modNames, (m, _) <- lookupModuleInAllPackages df mn ]
|
||||
#else
|
||||
pkgCfgs = allExposedPackageConfigs df
|
||||
mods = [ mkModule pid modname | p <- pkgCfgs
|
||||
, let pid = packageConfigId p
|
||||
, modname <- exposedModules p ]
|
||||
#endif
|
||||
in mods
|
||||
|
||||
isSynTyCon :: TyCon -> Bool
|
||||
#if __GLASGOW_HASKELL__ >= 710
|
||||
isSynTyCon = GHC.isTypeSynonymTyCon
|
||||
#else
|
||||
isSynTyCon = GHC.isSynTyCon
|
||||
#endif
|
||||
|
||||
|
||||
parseModuleHeader
|
||||
:: String -- ^ Haskell module source text (full Unicode is supported)
|
||||
-> DynFlags
|
||||
-> FilePath -- ^ the filename (for source locations)
|
||||
-> Either ErrorMessages (WarningMessages, Located (HsModule RdrName))
|
||||
parseModuleHeader str dflags filename =
|
||||
let
|
||||
loc = mkRealSrcLoc (mkFastString filename) 1 1
|
||||
buf = stringToStringBuffer str
|
||||
in
|
||||
case L.unP Parser.parseHeader (mkPState dflags buf loc) of
|
||||
|
||||
PFailed sp err ->
|
||||
#if __GLASGOW_HASKELL__ >= 706
|
||||
Left (unitBag (mkPlainErrMsg dflags sp err))
|
||||
#else
|
||||
Left (unitBag (mkPlainErrMsg sp err))
|
||||
#endif
|
||||
|
||||
POk pst rdr_module ->
|
||||
let (warns,_) = getMessages pst in
|
||||
Right (warns, rdr_module)
|
||||
|
@ -4,53 +4,27 @@ module Language.Haskell.GhcMod.GhcPkg (
|
||||
, ghcPkgDbStackOpts
|
||||
, ghcDbStackOpts
|
||||
, ghcDbOpt
|
||||
, fromInstalledPackageId
|
||||
, fromInstalledPackageId'
|
||||
, getPackageDbStack
|
||||
, getPackageCachePaths
|
||||
) where
|
||||
|
||||
import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt)
|
||||
import Control.Applicative ((<$>))
|
||||
import Data.List (intercalate)
|
||||
import Control.Applicative
|
||||
import Data.List.Split (splitOn)
|
||||
import Data.Maybe
|
||||
import Distribution.Package (InstalledPackageId(..))
|
||||
import Exception (handleIO)
|
||||
import Language.Haskell.GhcMod.PathsAndFiles
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import System.Directory (doesDirectoryExist, getAppUserDataDirectory)
|
||||
import System.FilePath ((</>))
|
||||
import Prelude
|
||||
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Monad.Types
|
||||
import Language.Haskell.GhcMod.CabalHelper
|
||||
import Language.Haskell.GhcMod.PathsAndFiles
|
||||
|
||||
ghcVersion :: Int
|
||||
ghcVersion = read cProjectVersionInt
|
||||
|
||||
getPackageDbStack :: FilePath -- ^ Project Directory (where the
|
||||
-- cabal.sandbox.config file would be if it
|
||||
-- exists)
|
||||
-> IO [GhcPkgDb]
|
||||
getPackageDbStack cdir = do
|
||||
mSDir <- getSandboxDb cdir
|
||||
return $ [GlobalDb] ++ case mSDir of
|
||||
Nothing -> [UserDb]
|
||||
Just db -> [PackageDb db]
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
fromInstalledPackageId' :: InstalledPackageId -> Maybe Package
|
||||
fromInstalledPackageId' pid = let
|
||||
InstalledPackageId pkg = pid
|
||||
in case reverse $ splitOn "-" pkg of
|
||||
i:v:rest -> Just (intercalate "-" (reverse rest), v, i)
|
||||
_ -> Nothing
|
||||
|
||||
fromInstalledPackageId :: InstalledPackageId -> Package
|
||||
fromInstalledPackageId pid =
|
||||
case fromInstalledPackageId' pid of
|
||||
Just p -> p
|
||||
Nothing -> error $
|
||||
"fromInstalledPackageId: `"++show pid++"' is not a valid package-id"
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Get options needed to add a list of package dbs to ghc-pkg's db stack
|
||||
@ -85,11 +59,24 @@ ghcDbOpt (PackageDb pkgDb)
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
getPackageDbStack :: IOish m => GhcModT m [GhcPkgDb]
|
||||
getPackageDbStack = do
|
||||
crdl <- cradle
|
||||
mCusPkgStack <- getCustomPkgDbStack
|
||||
stack <- case cradleProjectType crdl of
|
||||
PlainProject ->
|
||||
return [GlobalDb, UserDb]
|
||||
SandboxProject -> do
|
||||
Just db <- liftIO $ getSandboxDb $ cradleRootDir crdl
|
||||
return $ [GlobalDb, db]
|
||||
CabalProject ->
|
||||
getCabalPackageDbStack
|
||||
return $ fromMaybe stack mCusPkgStack
|
||||
|
||||
getPackageCachePaths :: FilePath -> Cradle -> IO [FilePath]
|
||||
getPackageCachePaths sysPkgCfg crdl =
|
||||
catMaybes <$> resolvePackageConfig sysPkgCfg `mapM` cradlePkgDbStack crdl
|
||||
|
||||
getPackageCachePaths :: IOish m => FilePath -> GhcModT m [FilePath]
|
||||
getPackageCachePaths sysPkgCfg = do
|
||||
pkgDbStack <- getPackageDbStack
|
||||
catMaybes <$> (liftIO . resolvePackageConfig sysPkgCfg) `mapM` pkgDbStack
|
||||
|
||||
-- TODO: use PkgConfRef
|
||||
--- Copied from ghc module `Packages' unfortunately it's not exported :/
|
||||
|
263
Language/Haskell/GhcMod/HomeModuleGraph.hs
Normal file
263
Language/Haskell/GhcMod/HomeModuleGraph.hs
Normal 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
|
@ -3,20 +3,25 @@ module Language.Haskell.GhcMod.Info (
|
||||
, types
|
||||
) where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Applicative
|
||||
import Data.Function (on)
|
||||
import Data.List (sortBy)
|
||||
import Data.Maybe (catMaybes)
|
||||
import System.FilePath
|
||||
import Exception (ghandle, SomeException(..))
|
||||
import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan, Type)
|
||||
import Prelude
|
||||
import qualified GHC as G
|
||||
import Language.Haskell.GhcMod.Doc (showPage)
|
||||
import Language.Haskell.GhcMod.Gap (HasType(..))
|
||||
import qualified Language.Haskell.GhcMod.Gap as Gap
|
||||
|
||||
import Language.Haskell.GhcMod.Convert
|
||||
import Language.Haskell.GhcMod.Doc
|
||||
import Language.Haskell.GhcMod.DynFlags
|
||||
import Language.Haskell.GhcMod.Gap
|
||||
import Language.Haskell.GhcMod.Logging
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.SrcUtils
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Convert
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
@ -25,14 +30,22 @@ info :: IOish m
|
||||
=> FilePath -- ^ A target file.
|
||||
-> Expression -- ^ A Haskell expression.
|
||||
-> GhcModT m String
|
||||
info file expr = do
|
||||
opt <- options
|
||||
convert opt <$> ghandle handler body
|
||||
info file expr =
|
||||
ghandle handler $
|
||||
runGmlT' [Left file] deferErrors $
|
||||
withContext $
|
||||
convert <$> options <*> body
|
||||
where
|
||||
body = inModuleContext file $ \dflag style -> do
|
||||
handler (SomeException ex) = do
|
||||
gmLog GmException "info" $ text "" $$ nest 4 (showDoc ex)
|
||||
convert' "Cannot show info"
|
||||
|
||||
body :: GhcMonad m => m String
|
||||
body = do
|
||||
sdoc <- Gap.infoThing expr
|
||||
return $ showPage dflag style sdoc
|
||||
handler (SomeException _) = return "Cannot show info"
|
||||
st <- getStyle
|
||||
dflag <- G.getSessionDynFlags
|
||||
return $ showPage dflag st sdoc
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
@ -42,15 +55,20 @@ types :: IOish m
|
||||
-> Int -- ^ Line number.
|
||||
-> Int -- ^ Column number.
|
||||
-> GhcModT m String
|
||||
types file lineNo colNo = do
|
||||
opt <- options
|
||||
convert opt <$> ghandle handler body
|
||||
where
|
||||
body = inModuleContext file $ \dflag style -> do
|
||||
modSum <- Gap.fileModSummary file
|
||||
types file lineNo colNo =
|
||||
ghandle handler $
|
||||
runGmlT' [Left file] deferErrors $
|
||||
withContext $ do
|
||||
crdl <- cradle
|
||||
modSum <- Gap.fileModSummary (cradleCurrentDir crdl </> file)
|
||||
srcSpanTypes <- getSrcSpanType modSum lineNo colNo
|
||||
return $ map (toTup dflag style) $ sortBy (cmp `on` fst) srcSpanTypes
|
||||
handler (SomeException _) = return []
|
||||
dflag <- G.getSessionDynFlags
|
||||
st <- getStyle
|
||||
convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes
|
||||
where
|
||||
handler (SomeException ex) = do
|
||||
gmLog GmException "types" $ showDoc ex
|
||||
return []
|
||||
|
||||
getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)]
|
||||
getSrcSpanType modSum lineNo colNo = do
|
||||
|
@ -8,35 +8,33 @@ module Language.Haskell.GhcMod.Internal (
|
||||
, PackageVersion
|
||||
, PackageId
|
||||
, IncludeDir
|
||||
, CompilerOptions(..)
|
||||
-- * Cabal API
|
||||
, parseCabalFile
|
||||
, getCompilerOptions
|
||||
, cabalAllBuildInfo
|
||||
, cabalDependPackages
|
||||
, cabalSourceDirs
|
||||
, cabalAllTargets
|
||||
, GmlT(..)
|
||||
, MonadIO(..)
|
||||
, GmEnv(..)
|
||||
-- * Various Paths
|
||||
, ghcLibDir
|
||||
, ghcModExecutable
|
||||
-- * IO
|
||||
, getDynamicFlags
|
||||
-- * Targets
|
||||
, setTargetFiles
|
||||
-- * Logging
|
||||
, withLogger
|
||||
, setNoWarningFlags
|
||||
, setAllWarningFlags
|
||||
-- * Environment, state and logging
|
||||
, GhcModEnv(..)
|
||||
, newGhcModEnv
|
||||
, GhcModState
|
||||
, defaultState
|
||||
, CompilerMode(..)
|
||||
, GhcModLog
|
||||
, GmLog(..)
|
||||
, GmLogLevel(..)
|
||||
, gmSetLogLevel
|
||||
-- * Monad utilities
|
||||
, runGhcModT'
|
||||
, hoistGhcModT
|
||||
, runGmlT
|
||||
, runGmlT'
|
||||
, gmlGetSession
|
||||
, gmlSetSession
|
||||
, loadTargets
|
||||
, cabalResolvedComponents
|
||||
-- ** Accessing 'GhcModEnv' and 'GhcModState'
|
||||
, options
|
||||
, cradle
|
||||
@ -45,28 +43,33 @@ module Language.Haskell.GhcMod.Internal (
|
||||
, withOptions
|
||||
-- * 'GhcModError'
|
||||
, gmeDoc
|
||||
-- * 'GhcMonad' Choice
|
||||
, (||>)
|
||||
, goNext
|
||||
, runAnyOne
|
||||
-- * World
|
||||
, World
|
||||
, getCurrentWorld
|
||||
, didWorldChange
|
||||
-- * Cabal Helper
|
||||
, ModulePath(..)
|
||||
, GmComponent(..)
|
||||
, GmComponentType(..)
|
||||
, GmModuleGraph(..)
|
||||
, prepareCabalHelper
|
||||
-- * Misc stuff
|
||||
, GHandler(..)
|
||||
, gcatches
|
||||
) where
|
||||
|
||||
import GHC.Paths (libdir)
|
||||
|
||||
import Language.Haskell.GhcMod.CabalApi
|
||||
import Language.Haskell.GhcMod.Target
|
||||
import Language.Haskell.GhcMod.DynFlags
|
||||
import Language.Haskell.GhcMod.Error
|
||||
import Language.Haskell.GhcMod.GHCChoice
|
||||
import Language.Haskell.GhcMod.Logger
|
||||
import Language.Haskell.GhcMod.Logging
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.Target
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Utils
|
||||
import Language.Haskell.GhcMod.World
|
||||
import Language.Haskell.GhcMod.CabalHelper
|
||||
|
||||
-- | Obtaining the directory for ghc system libraries.
|
||||
ghcLibDir :: FilePath
|
||||
|
@ -1,31 +1,33 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Language.Haskell.GhcMod.Logger (
|
||||
withLogger
|
||||
, withLoggerTwice
|
||||
, withLogger'
|
||||
, checkErrorPrefix
|
||||
, errsToStr
|
||||
, errBagToStrList
|
||||
) where
|
||||
|
||||
import Bag (Bag, bagToList, emptyBag, consBag, filterBag, unionBags)
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Arrow
|
||||
import Control.Applicative
|
||||
import Data.List (isPrefixOf)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
|
||||
import Data.List (isPrefixOf, find, nub, isInfixOf)
|
||||
import Data.Maybe (fromMaybe, isJust)
|
||||
import ErrUtils (ErrMsg, WarnMsg, errMsgShortDoc, errMsgExtraInfo, mkWarnMsg)
|
||||
import Exception (ghandle)
|
||||
import GHC (DynFlags, SrcSpan, Severity(SevError))
|
||||
import qualified GHC as G
|
||||
import HscTypes (SourceError, srcErrorMessages)
|
||||
import Language.Haskell.GhcMod.Doc (showPage, getStyle)
|
||||
import Language.Haskell.GhcMod.DynFlags (withDynFlags, withCmdFlags)
|
||||
import qualified Language.Haskell.GhcMod.Gap as Gap
|
||||
import Language.Haskell.GhcMod.Convert (convert')
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Outputable (PprStyle, SDoc, qualName, qualModule, mkErrStyle, neverQualify)
|
||||
import System.FilePath (normalise)
|
||||
import Text.PrettyPrint
|
||||
|
||||
----------------------------------------------------------------
|
||||
import ErrUtils (ErrMsg, errMsgShortDoc, errMsgExtraInfo)
|
||||
import GHC (DynFlags, SrcSpan, Severity(SevError))
|
||||
import HscTypes
|
||||
import Outputable
|
||||
import qualified GHC as G
|
||||
import Bag
|
||||
|
||||
import Language.Haskell.GhcMod.Convert
|
||||
import Language.Haskell.GhcMod.Doc (showPage)
|
||||
import Language.Haskell.GhcMod.DynFlags (withDynFlags)
|
||||
import Language.Haskell.GhcMod.Monad.Types
|
||||
import Language.Haskell.GhcMod.Error
|
||||
import qualified Language.Haskell.GhcMod.Gap as Gap
|
||||
import Prelude
|
||||
|
||||
type Builder = [String] -> [String]
|
||||
|
||||
@ -39,178 +41,94 @@ emptyLog = Log [] id
|
||||
newLogRef :: IO LogRef
|
||||
newLogRef = LogRef <$> newIORef emptyLog
|
||||
|
||||
readAndClearLogRef :: IOish m => LogRef -> GhcModT m String
|
||||
readAndClearLogRef :: LogRef -> IO [String]
|
||||
readAndClearLogRef (LogRef ref) = do
|
||||
Log _ b <- liftIO $ readIORef ref
|
||||
liftIO $ writeIORef ref emptyLog
|
||||
convert' (b [])
|
||||
Log _ b <- readIORef ref
|
||||
writeIORef ref emptyLog
|
||||
return $ b []
|
||||
|
||||
appendLogRef :: DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
|
||||
appendLogRef df (LogRef ref) _ sev src style msg = modifyIORef ref update
|
||||
appendLogRef df (LogRef ref) _ sev src st msg = modifyIORef ref update
|
||||
where
|
||||
l = ppMsg src sev df style msg
|
||||
l = ppMsg src sev df st msg
|
||||
update lg@(Log ls b)
|
||||
| l `elem` ls = lg
|
||||
| otherwise = Log (l:ls) (b . (l:))
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
data LogBag = LogBag (Bag WarnMsg)
|
||||
newtype LogBagRef = LogBagRef (IORef LogBag)
|
||||
|
||||
emptyLogBag :: LogBag
|
||||
emptyLogBag = LogBag emptyBag
|
||||
|
||||
newLogBagRef :: IO LogBagRef
|
||||
newLogBagRef = LogBagRef <$> newIORef emptyLogBag
|
||||
|
||||
readAndClearLogBagRef :: IOish m => LogBagRef -> GhcModT m (Bag WarnMsg)
|
||||
readAndClearLogBagRef (LogBagRef ref) = do
|
||||
LogBag b <- liftIO $ readIORef ref
|
||||
liftIO $ writeIORef ref emptyLogBag
|
||||
return b
|
||||
|
||||
appendLogBagRef :: DynFlags -> LogBagRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
|
||||
appendLogBagRef df (LogBagRef ref) _ _ src style msg = modifyIORef ref update
|
||||
where
|
||||
qstyle = (qualName style, qualModule style)
|
||||
#if __GLASGOW_HASKELL__ >= 706
|
||||
warnMsg = mkWarnMsg df src qstyle msg
|
||||
#else
|
||||
warnMsg = mkWarnMsg src qstyle msg
|
||||
#endif
|
||||
warnBag = consBag warnMsg emptyBag
|
||||
update (LogBag b) = let (b1,b2) = mergeErrors df style b warnBag
|
||||
in LogBag $ b1 `unionBags` b2
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Set the session flag (e.g. "-Wall" or "-w:") then
|
||||
-- executes a body. Logged messages are returned as 'String'.
|
||||
-- Right is success and Left is failure.
|
||||
withLogger :: IOish m
|
||||
withLogger :: (GmGhc m, GmEnv m)
|
||||
=> (DynFlags -> DynFlags)
|
||||
-> GhcModT m ()
|
||||
-> GhcModT m (Either String String)
|
||||
withLogger setDF body = ghandle sourceError $ do
|
||||
logref <- liftIO newLogRef
|
||||
wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options
|
||||
withDynFlags (setLogger logref . setDF) $
|
||||
withCmdFlags wflags $ do
|
||||
body
|
||||
Right <$> readAndClearLogRef logref
|
||||
-> m a
|
||||
-> m (Either String (String, a))
|
||||
withLogger f action = do
|
||||
env <- G.getSession
|
||||
opts <- options
|
||||
let conv = convert opts
|
||||
eres <- withLogger' env $ \setDf ->
|
||||
withDynFlags (f . setDf) action
|
||||
return $ either (Left . conv) (Right . first conv) eres
|
||||
|
||||
withLogger' :: IOish m
|
||||
=> HscEnv -> ((DynFlags -> DynFlags) -> m a) -> m (Either [String] ([String], a))
|
||||
withLogger' env action = do
|
||||
logref <- liftIO $ newLogRef
|
||||
|
||||
let dflags = hsc_dflags env
|
||||
pu = icPrintUnqual dflags (hsc_IC env)
|
||||
st = mkUserStyle pu AllTheWay
|
||||
|
||||
fn df = setLogger logref df
|
||||
|
||||
a <- gcatches (Right <$> action fn) (handlers dflags st)
|
||||
ls <- liftIO $ readAndClearLogRef logref
|
||||
|
||||
return $ ((,) ls <$> a)
|
||||
|
||||
where
|
||||
setLogger logref df = Gap.setLogAction df $ appendLogRef df logref
|
||||
handlers df st = [
|
||||
GHandler $ \ex -> return $ Left $ sourceError df st ex,
|
||||
GHandler $ \ex -> return $ Left [render $ ghcExceptionDoc ex]
|
||||
]
|
||||
|
||||
withLoggerTwice :: IOish m
|
||||
=> (DynFlags -> DynFlags)
|
||||
-> GhcModT m ()
|
||||
-> (DynFlags -> DynFlags)
|
||||
-> GhcModT m ()
|
||||
-> GhcModT m (Either String String)
|
||||
withLoggerTwice setDF1 body1 setDF2 body2 = do
|
||||
err1 <- ghandle sourceErrorBag $ do
|
||||
logref <- liftIO newLogBagRef
|
||||
wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options
|
||||
withDynFlags (setLogger logref . setDF1) $
|
||||
withCmdFlags wflags $ do
|
||||
body1
|
||||
Right <$> readAndClearLogBagRef logref
|
||||
err2 <- ghandle sourceErrorBag $ do
|
||||
logref <- liftIO newLogBagRef
|
||||
wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options
|
||||
withDynFlags (setLogger logref . setDF2) $
|
||||
withCmdFlags wflags $ do
|
||||
body2
|
||||
Right <$> readAndClearLogBagRef logref
|
||||
-- Merge errors and warnings
|
||||
dflags <- G.getSessionDynFlags
|
||||
style <- getStyle
|
||||
case (err1, err2) of
|
||||
(Right b1, Right b2) -> do let (warn1,_) = mergeErrors dflags style b1 b2
|
||||
errAndWarnBagToStr Right emptyBag (warn1 `unionBags` b2)
|
||||
(Left b1, Right b2) -> do let (err,warn) = mergeErrors dflags style b1 b2
|
||||
errAndWarnBagToStr Right err warn
|
||||
(Right b1, Left b2) -> do let (err,warn) = mergeErrors dflags style b2 b1
|
||||
errAndWarnBagToStr Right err warn
|
||||
(Left b1, Left b2) -> do let (err1',err2') = mergeErrors dflags style b1 b2
|
||||
errAndWarnBagToStr Right (err1' `unionBags` err2') emptyBag
|
||||
where
|
||||
setLogger logref df = Gap.setLogAction df $ appendLogBagRef df logref
|
||||
errBagToStrList :: HscEnv -> Bag ErrMsg -> [String]
|
||||
errBagToStrList env errs = let
|
||||
dflags = hsc_dflags env
|
||||
pu = icPrintUnqual dflags (hsc_IC env)
|
||||
st = mkUserStyle pu AllTheWay
|
||||
in errsToStr dflags st $ bagToList errs
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Converting 'SourceError' to 'String'.
|
||||
sourceError :: IOish m => SourceError -> GhcModT m (Either String String)
|
||||
sourceError err = errBagToStr (srcErrorMessages err)
|
||||
sourceError :: DynFlags -> PprStyle -> SourceError -> [String]
|
||||
sourceError df st src_err = errsToStr df st $ reverse $ bagToList $ srcErrorMessages src_err
|
||||
|
||||
errBagToStr :: IOish m => Bag ErrMsg -> GhcModT m (Either String String)
|
||||
errBagToStr = errBagToStr' Left
|
||||
|
||||
errBagToStr' :: IOish m => (String -> a) -> Bag ErrMsg -> GhcModT m a
|
||||
errBagToStr' f err = do
|
||||
dflags <- G.getSessionDynFlags
|
||||
style <- getStyle
|
||||
ret <- convert' (errBagToStrList dflags style err)
|
||||
return $ f ret
|
||||
|
||||
errAndWarnBagToStr :: IOish m => (String -> a) -> Bag ErrMsg -> Bag WarnMsg -> GhcModT m a
|
||||
errAndWarnBagToStr f err warn = do
|
||||
dflags <- G.getSessionDynFlags
|
||||
-- style <- toGhcModT getStyle
|
||||
#if __GLASGOW_HASKELL__ >= 706
|
||||
let style = mkErrStyle dflags neverQualify
|
||||
#else
|
||||
let style = mkErrStyle neverQualify
|
||||
#endif
|
||||
ret <- convert' $ nub (errBagToStrList dflags style err ++ warnBagToStrList dflags style warn)
|
||||
return $ f ret
|
||||
|
||||
errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String]
|
||||
errBagToStrList dflag style = map (ppErrMsg dflag style) . reverse . bagToList
|
||||
|
||||
warnBagToStrList :: DynFlags -> PprStyle -> Bag WarnMsg -> [String]
|
||||
warnBagToStrList dflag style = map (ppWarnMsg dflag style) . reverse . bagToList
|
||||
|
||||
sourceErrorBag :: IOish m => SourceError -> GhcModT m (Either (Bag ErrMsg) (Bag WarnMsg))
|
||||
sourceErrorBag err = return $ Left (srcErrorMessages err)
|
||||
|
||||
mergeErrors :: DynFlags -> PprStyle -> Bag ErrMsg -> Bag ErrMsg -> (Bag ErrMsg, Bag ErrMsg)
|
||||
mergeErrors dflag style b1 b2 =
|
||||
let b1Msgs = map (\err1 -> let m = ppWarnMsg dflag style err1 in (m, head $ lines m))
|
||||
(bagToList b1)
|
||||
mustBeB2 = \err2 -> let msg2 = ppWarnMsg dflag style err2
|
||||
line2 = head $ lines msg2
|
||||
in not . isJust $ find (\(msg1, line1) -> msg1 == msg2 || (line1 == line2 && isHoleMsg line1)) b1Msgs
|
||||
in (b1, filterBag mustBeB2 b2)
|
||||
|
||||
isHoleMsg :: String -> Bool
|
||||
isHoleMsg = isInfixOf "Found hole"
|
||||
errsToStr :: DynFlags -> PprStyle -> [ErrMsg] -> [String]
|
||||
errsToStr df st = map (ppErrMsg df st)
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
ppErrMsg :: DynFlags -> PprStyle -> ErrMsg -> String
|
||||
ppErrMsg dflag style err = ppMsg spn SevError dflag style msg ++ (if null ext then "" else "\n" ++ ext)
|
||||
ppErrMsg dflag st err =
|
||||
ppMsg spn SevError dflag st msg ++ (if null ext then "" else "\n" ++ ext)
|
||||
where
|
||||
spn = Gap.errorMsgSpan err
|
||||
msg = errMsgShortDoc err
|
||||
ext = showPage dflag style (errMsgExtraInfo err)
|
||||
|
||||
ppWarnMsg :: DynFlags -> PprStyle -> ErrMsg -> String
|
||||
ppWarnMsg dflag style err = ppMsg spn G.SevWarning dflag style msg ++ (if null ext then "" else "\n" ++ ext)
|
||||
where
|
||||
spn = Gap.errorMsgSpan err
|
||||
msg = errMsgShortDoc err
|
||||
ext = showPage dflag style (errMsgExtraInfo err)
|
||||
ext = showPage dflag st (errMsgExtraInfo err)
|
||||
|
||||
ppMsg :: SrcSpan -> Severity-> DynFlags -> PprStyle -> SDoc -> String
|
||||
ppMsg spn sev dflag style msg = prefix ++ cts
|
||||
ppMsg spn sev dflag st msg = prefix ++ cts
|
||||
where
|
||||
cts = showPage dflag style msg
|
||||
prefix = ppMsgPrefix spn sev dflag style cts
|
||||
cts = showPage dflag st msg
|
||||
prefix = ppMsgPrefix spn sev dflag st cts
|
||||
|
||||
ppMsgPrefix :: SrcSpan -> Severity-> DynFlags -> PprStyle -> String -> String
|
||||
ppMsgPrefix spn sev dflag _style cts =
|
||||
ppMsgPrefix spn sev dflag _st cts =
|
||||
let defaultPrefix
|
||||
| Gap.isDumpSplices dflag = ""
|
||||
| otherwise = checkErrorPrefix
|
||||
|
102
Language/Haskell/GhcMod/Logging.hs
Normal file
102
Language/Haskell/GhcMod/Logging.hs
Normal 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 ()
|
@ -1,32 +1,26 @@
|
||||
module Language.Haskell.GhcMod.Modules (modules) where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Exception (SomeException(..))
|
||||
import Data.List (nub, sort)
|
||||
import qualified GHC as G
|
||||
import Control.Arrow
|
||||
import Data.List
|
||||
import Language.Haskell.GhcMod.Convert
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Packages (pkgIdMap, exposedModules, sourcePackageId, display)
|
||||
import UniqFM (eltsUFM)
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.Gap ( listVisibleModuleNames
|
||||
, lookupModulePackageInAllPackages
|
||||
)
|
||||
|
||||
import qualified GHC as G
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Listing installed modules.
|
||||
modules :: IOish m => GhcModT m String
|
||||
modules :: (IOish m, GmEnv m, GmState m, GmLog m) => m String
|
||||
modules = do
|
||||
opt <- options
|
||||
convert opt . arrange opt <$> (getModules `G.gcatch` handler)
|
||||
Options { detailed } <- options
|
||||
df <- runGmPkgGhc G.getSessionDynFlags
|
||||
let mns = listVisibleModuleNames df
|
||||
pmnss = map (first moduleNameString) $ zip mns (modulePkg df `map` mns)
|
||||
convert' $ nub [ if detailed then pkg ++ " " ++ mn else mn
|
||||
| (mn, pkgs) <- pmnss, pkg <- pkgs ]
|
||||
where
|
||||
getModules = getExposedModules <$> G.getSessionDynFlags
|
||||
getExposedModules = concatMap exposedModules'
|
||||
. eltsUFM . pkgIdMap . G.pkgState
|
||||
exposedModules' p =
|
||||
map G.moduleNameString (exposedModules p)
|
||||
`zip`
|
||||
repeat (display $ sourcePackageId p)
|
||||
arrange opt = nub . sort . map (dropPkgs opt)
|
||||
dropPkgs opt (name, pkg)
|
||||
| detailed opt = name ++ " " ++ pkg
|
||||
| otherwise = name
|
||||
handler (SomeException _) = return []
|
||||
modulePkg df = lookupModulePackageInAllPackages df
|
||||
|
@ -1,289 +1,100 @@
|
||||
{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-}
|
||||
{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-}
|
||||
{-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
-- ghc-mod: Making Haskell development *more* fun
|
||||
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
|
||||
--
|
||||
-- This program is free software: you can redistribute it and/or modify
|
||||
-- it under the terms of the GNU Affero General Public License as published by
|
||||
-- the Free Software Foundation, either version 3 of the License, or
|
||||
-- (at your option) any later version.
|
||||
--
|
||||
-- This program is distributed in the hope that it will be useful,
|
||||
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
-- GNU Affero General Public License for more details.
|
||||
--
|
||||
-- You should have received a copy of the GNU Affero General Public License
|
||||
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Language.Haskell.GhcMod.Monad (
|
||||
-- * Monad Types
|
||||
GhcModT
|
||||
, IOish
|
||||
-- ** Environment, state and logging
|
||||
, GhcModEnv(..)
|
||||
, newGhcModEnv
|
||||
, GhcModState(..)
|
||||
, defaultState
|
||||
, CompilerMode(..)
|
||||
, GhcModLog
|
||||
, GhcModError(..)
|
||||
-- * Monad utilities
|
||||
, runGhcModT
|
||||
runGhcModT
|
||||
, runGhcModT'
|
||||
, runGhcModT''
|
||||
, hoistGhcModT
|
||||
-- ** Accessing 'GhcModEnv' and 'GhcModState'
|
||||
, gmsGet
|
||||
, gmsPut
|
||||
, options
|
||||
, cradle
|
||||
, getCompilerMode
|
||||
, setCompilerMode
|
||||
, withOptions
|
||||
, withTempSession
|
||||
, overrideGhcUserOptions
|
||||
-- ** Re-exporting convenient stuff
|
||||
, liftIO
|
||||
, module Control.Monad.Reader.Class
|
||||
, module Control.Monad.Journal.Class
|
||||
, runGmlT
|
||||
, runGmlT'
|
||||
, runGmlTWith
|
||||
, runGmPkgGhc
|
||||
, withGhcModEnv
|
||||
, withGhcModEnv'
|
||||
, module Language.Haskell.GhcMod.Monad.Types
|
||||
) where
|
||||
|
||||
#if __GLASGOW_HASKELL__ < 708
|
||||
-- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different
|
||||
-- classes before ghc 7.8
|
||||
#define DIFFERENT_MONADIO 1
|
||||
|
||||
-- RWST doen't have a MonadIO instance before ghc 7.8
|
||||
#define MONADIO_INSTANCES 1
|
||||
#endif
|
||||
|
||||
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Monad.Types
|
||||
import Language.Haskell.GhcMod.Error
|
||||
import Language.Haskell.GhcMod.Logging
|
||||
import Language.Haskell.GhcMod.Cradle
|
||||
import Language.Haskell.GhcMod.DynFlags
|
||||
import Language.Haskell.GhcMod.GhcPkg
|
||||
import Language.Haskell.GhcMod.CabalApi
|
||||
import qualified Language.Haskell.GhcMod.Gap as Gap
|
||||
import Language.Haskell.GhcMod.Target
|
||||
import Language.Haskell.GhcMod.Output
|
||||
|
||||
import DynFlags
|
||||
import GHC
|
||||
import qualified GHC as G
|
||||
import GHC.Paths (libdir)
|
||||
import GhcMonad hiding (withTempSession)
|
||||
#if __GLASGOW_HASKELL__ <= 702
|
||||
import HscTypes
|
||||
#endif
|
||||
|
||||
-- MonadUtils of GHC 7.6 or earlier defines its own MonadIO.
|
||||
-- RWST does not automatically become an instance of MonadIO.
|
||||
-- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class.
|
||||
-- So, RWST automatically becomes an instance of MonadIO.
|
||||
import MonadUtils
|
||||
|
||||
#if DIFFERENT_MONADIO
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import qualified Control.Monad.IO.Class
|
||||
import Data.Monoid (Monoid)
|
||||
#endif
|
||||
|
||||
import Control.Applicative (Alternative)
|
||||
import Control.Arrow (first)
|
||||
import Control.Monad (MonadPlus, void)
|
||||
#if !MIN_VERSION_monad_control(1,0,0)
|
||||
import Control.Monad (liftM)
|
||||
#endif
|
||||
import Control.Monad.Base (MonadBase, liftBase)
|
||||
import Control.Applicative
|
||||
|
||||
-- Monad transformer stuff
|
||||
import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith,
|
||||
control, liftBaseOp, liftBaseOp_)
|
||||
import Control.Concurrent
|
||||
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Reader.Class
|
||||
import Control.Monad.Writer.Class (MonadWriter)
|
||||
import Control.Monad.State.Class (MonadState(..))
|
||||
import Control.Monad.Reader (runReaderT)
|
||||
import Control.Monad.State.Strict (runStateT)
|
||||
import Control.Monad.Trans.Journal (runJournalT)
|
||||
|
||||
import Control.Monad.Error (ErrorT, runErrorT)
|
||||
import Control.Monad.Reader (ReaderT, runReaderT)
|
||||
import Control.Monad.State.Strict (StateT, runStateT)
|
||||
import Control.Monad.Trans.Journal (JournalT, runJournalT)
|
||||
#ifdef MONADIO_INSTANCES
|
||||
import Control.Monad.Trans.Maybe (MaybeT)
|
||||
import Control.Monad.Error (Error(..))
|
||||
#endif
|
||||
import Control.Monad.Journal.Class
|
||||
import Exception (ExceptionMonad(..))
|
||||
|
||||
import Data.Maybe (isJust)
|
||||
import Data.IORef (IORef, readIORef, writeIORef, newIORef)
|
||||
import System.Directory (getCurrentDirectory)
|
||||
import System.Directory
|
||||
import Prelude
|
||||
|
||||
----------------------------------------------------------------
|
||||
withCradle :: IOish m => FilePath -> (Cradle -> m a) -> m a
|
||||
withCradle cradledir f =
|
||||
gbracket (liftIO $ findCradle' cradledir) (liftIO . cleanupCradle) f
|
||||
|
||||
data GhcModEnv = GhcModEnv {
|
||||
gmGhcSession :: !(IORef HscEnv)
|
||||
, gmOptions :: Options
|
||||
, gmCradle :: Cradle
|
||||
}
|
||||
|
||||
type GhcModLog = ()
|
||||
|
||||
data GhcModState = GhcModState {
|
||||
gmCompilerMode :: CompilerMode
|
||||
} deriving (Eq,Show,Read)
|
||||
|
||||
data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read)
|
||||
|
||||
defaultState :: GhcModState
|
||||
defaultState = GhcModState Simple
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | This is basically a newtype wrapper around 'StateT', 'ErrorT', 'JournalT'
|
||||
-- and 'ReaderT' with custom instances for 'GhcMonad' and it's constraints that
|
||||
-- means you can run (almost) all functions from the GHC API on top of 'GhcModT'
|
||||
-- transparently.
|
||||
--
|
||||
-- The inner monad @m@ should have instances for 'MonadIO' and
|
||||
-- 'MonadBaseControl' 'IO', in the common case this is simply 'IO'. Most @mtl@
|
||||
-- monads already have 'MonadBaseControl' 'IO' instances, see the
|
||||
-- @monad-control@ package.
|
||||
newtype GhcModT m a = GhcModT {
|
||||
unGhcModT :: StateT GhcModState
|
||||
(ErrorT GhcModError
|
||||
(JournalT GhcModLog
|
||||
(ReaderT GhcModEnv m) ) ) a
|
||||
} deriving ( Functor
|
||||
, Applicative
|
||||
, Alternative
|
||||
, Monad
|
||||
, MonadPlus
|
||||
#if DIFFERENT_MONADIO
|
||||
, Control.Monad.IO.Class.MonadIO
|
||||
#endif
|
||||
, MonadReader GhcModEnv -- TODO: make MonadReader instance
|
||||
-- pass-through like MonadState
|
||||
, MonadWriter w
|
||||
, MonadError GhcModError
|
||||
)
|
||||
|
||||
instance MonadIO m => MonadIO (GhcModT m) where
|
||||
liftIO action = do
|
||||
res <- GhcModT . liftIO . liftIO . liftIO . liftIO $ try action
|
||||
case res of
|
||||
Right a -> return a
|
||||
|
||||
Left e | isIOError e ->
|
||||
throwError $ GMEIOException (fromEx e :: IOError)
|
||||
Left e | isGhcModError e ->
|
||||
throwError $ (fromEx e :: GhcModError)
|
||||
Left e -> throw e
|
||||
withGhcModEnv :: IOish m => FilePath -> Options -> (GhcModEnv -> m a) -> m a
|
||||
withGhcModEnv dir opt f = withCradle dir (withGhcModEnv' opt f)
|
||||
|
||||
withGhcModEnv' :: IOish m => Options -> (GhcModEnv -> m a) -> Cradle -> m a
|
||||
withGhcModEnv' opt f crdl = do
|
||||
olddir <- liftIO getCurrentDirectory
|
||||
c <- liftIO newChan
|
||||
let outp = case linePrefix opt of
|
||||
Just _ -> GmOutputChan c
|
||||
Nothing -> GmOutputStdio
|
||||
gbracket_ (setup c) (teardown olddir) (f $ GhcModEnv opt crdl outp)
|
||||
where
|
||||
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
|
||||
setup c = liftIO $ do
|
||||
setCurrentDirectory $ cradleRootDir crdl
|
||||
forkIO $ stdoutGateway c
|
||||
|
||||
isGhcModError se =
|
||||
case fromException se of
|
||||
Just (_ :: GhcModError) -> True
|
||||
Nothing -> False
|
||||
teardown olddir tid = liftIO $ do
|
||||
setCurrentDirectory olddir
|
||||
killThread tid
|
||||
|
||||
|
||||
instance MonadTrans (GhcModT) where
|
||||
lift = GhcModT . lift . lift . lift . lift
|
||||
|
||||
instance MonadState s m => MonadState s (GhcModT m) where
|
||||
get = GhcModT $ lift $ lift $ lift get
|
||||
put = GhcModT . lift . lift . lift . put
|
||||
state = GhcModT . lift . lift . lift . state
|
||||
|
||||
|
||||
#if MONADIO_INSTANCES
|
||||
instance MonadIO m => MonadIO (StateT s m) where
|
||||
liftIO = lift . liftIO
|
||||
|
||||
instance MonadIO m => MonadIO (ReaderT r m) where
|
||||
liftIO = lift . liftIO
|
||||
|
||||
instance (Monoid w, MonadIO m) => MonadIO (JournalT w m) where
|
||||
liftIO = lift . liftIO
|
||||
|
||||
instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where
|
||||
liftIO = lift . liftIO
|
||||
|
||||
instance MonadIO m => MonadIO (MaybeT m) where
|
||||
liftIO = lift . liftIO
|
||||
#endif
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Initialize the 'DynFlags' relating to the compilation of a single
|
||||
-- file or GHC session according to the 'Cradle' and 'Options'
|
||||
-- provided.
|
||||
initializeFlagsWithCradle :: (IOish m, GhcMonad m, MonadError GhcModError m)
|
||||
=> Options
|
||||
-> Cradle
|
||||
-> m ()
|
||||
initializeFlagsWithCradle opt c
|
||||
| cabal = withCabal
|
||||
| otherwise = withSandbox
|
||||
where
|
||||
mCabalFile = cradleCabalFile c
|
||||
cabal = isJust mCabalFile
|
||||
ghcopts = ghcUserOptions opt
|
||||
withCabal = do
|
||||
let Just cabalFile = mCabalFile
|
||||
pkgDesc <- parseCabalFile c cabalFile
|
||||
compOpts <- getCompilerOptions ghcopts c pkgDesc
|
||||
initSession CabalPkg opt compOpts
|
||||
withSandbox = initSession SingleFile opt compOpts
|
||||
where
|
||||
importDirs = [".","..","../..","../../..","../../../..","../../../../.."]
|
||||
pkgOpts = ghcDbStackOpts $ cradlePkgDbStack c
|
||||
compOpts
|
||||
| null pkgOpts = CompilerOptions ghcopts importDirs []
|
||||
| otherwise = CompilerOptions (ghcopts ++ pkgOpts) [wdir,rdir] []
|
||||
wdir = cradleCurrentDir c
|
||||
rdir = cradleRootDir c
|
||||
|
||||
initSession :: GhcMonad m
|
||||
=> Build
|
||||
-> Options
|
||||
-> CompilerOptions
|
||||
-> m ()
|
||||
initSession build Options {..} CompilerOptions {..} = do
|
||||
df <- G.getSessionDynFlags
|
||||
void $ G.setSessionDynFlags =<< addCmdOpts ghcOptions
|
||||
( setModeSimple
|
||||
$ Gap.setFlags
|
||||
$ setIncludeDirs includeDirs
|
||||
$ setBuildEnv build
|
||||
$ setEmptyLogger
|
||||
$ Gap.addPackageFlags depPackages df)
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
newGhcModEnv :: Options -> FilePath -> IO GhcModEnv
|
||||
newGhcModEnv opt dir = do
|
||||
session <- newIORef (error "empty session")
|
||||
c <- findCradle' dir
|
||||
return GhcModEnv {
|
||||
gmGhcSession = session
|
||||
, gmOptions = opt
|
||||
, gmCradle = c
|
||||
}
|
||||
|
||||
cleanupGhcModEnv :: GhcModEnv -> IO ()
|
||||
cleanupGhcModEnv env = cleanupCradle $ gmCradle env
|
||||
gbracket_ ma mb mc = gbracket ma mb (const mc)
|
||||
|
||||
-- | Run a @GhcModT m@ computation.
|
||||
runGhcModT :: IOish m
|
||||
=> Options
|
||||
-> GhcModT m a
|
||||
-> m (Either GhcModError a, GhcModLog)
|
||||
runGhcModT opt action = gbracket newEnv delEnv $ \env -> do
|
||||
r <- first (fst <$>) <$> (runGhcModT' env defaultState $ do
|
||||
dflags <- getSessionDynFlags
|
||||
defaultCleanupHandler dflags $ do
|
||||
initializeFlagsWithCradle opt (gmCradle env)
|
||||
action)
|
||||
return r
|
||||
runGhcModT opt action = do
|
||||
dir <- liftIO getCurrentDirectory
|
||||
runGhcModT' dir opt action
|
||||
|
||||
where
|
||||
newEnv = liftBase $ newGhcModEnv opt =<< getCurrentDirectory
|
||||
delEnv = liftBase . cleanupGhcModEnv
|
||||
runGhcModT' :: IOish m
|
||||
=> FilePath
|
||||
-> Options
|
||||
-> GhcModT m a
|
||||
-> m (Either GhcModError a, GhcModLog)
|
||||
runGhcModT' dir opt action = liftIO (canonicalizePath dir) >>= \dir' ->
|
||||
withGhcModEnv dir' opt $ \env ->
|
||||
first (fst <$>) <$> runGhcModT'' env defaultGhcModState
|
||||
(gmSetLogLevel (logLevel opt) >> action)
|
||||
|
||||
-- | @hoistGhcModT result@. Embed a GhcModT computation's result into a GhcModT
|
||||
-- computation. Note that if the computation that returned @result@ modified the
|
||||
@ -292,7 +103,7 @@ hoistGhcModT :: IOish m
|
||||
=> (Either GhcModError a, GhcModLog)
|
||||
-> GhcModT m a
|
||||
hoistGhcModT (r,l) = do
|
||||
GhcModT (lift $ lift $ journal l) >> case r of
|
||||
gmlJournal l >> case r of
|
||||
Left e -> throwError e
|
||||
Right a -> return a
|
||||
|
||||
@ -301,179 +112,10 @@ hoistGhcModT (r,l) = do
|
||||
-- do with 'GhcModEnv' and 'GhcModState'.
|
||||
--
|
||||
-- You should probably look at 'runGhcModT' instead.
|
||||
runGhcModT' :: IOish m
|
||||
runGhcModT'' :: IOish m
|
||||
=> GhcModEnv
|
||||
-> GhcModState
|
||||
-> GhcModT m a
|
||||
-> m (Either GhcModError (a, GhcModState), GhcModLog)
|
||||
runGhcModT' r s a = do
|
||||
(res, w') <-
|
||||
flip runReaderT r $ runJournalT $ runErrorT $
|
||||
runStateT (unGhcModT $ initGhcMonad (Just libdir) >> a) s
|
||||
return (res, w')
|
||||
----------------------------------------------------------------
|
||||
-- | Make a copy of the 'gmGhcSession' IORef, run the action and restore the
|
||||
-- original 'HscEnv'.
|
||||
withTempSession :: IOish m => GhcModT m a -> GhcModT m a
|
||||
withTempSession action = do
|
||||
session <- gmGhcSession <$> ask
|
||||
savedHscEnv <- liftIO $ readIORef session
|
||||
a <- action
|
||||
liftIO $ writeIORef session savedHscEnv
|
||||
return a
|
||||
|
||||
-- | This is a very ugly workaround don't use it.
|
||||
overrideGhcUserOptions :: IOish m => ([GHCOption] -> GhcModT m b) -> GhcModT m b
|
||||
overrideGhcUserOptions action = withTempSession $ do
|
||||
env <- ask
|
||||
opt <- options
|
||||
let ghcOpts = ghcUserOptions opt
|
||||
opt' = opt { ghcUserOptions = [] }
|
||||
|
||||
initializeFlagsWithCradle opt' (gmCradle env)
|
||||
|
||||
action ghcOpts
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
gmeAsk :: IOish m => GhcModT m GhcModEnv
|
||||
gmeAsk = ask
|
||||
|
||||
gmsGet :: IOish m => GhcModT m GhcModState
|
||||
gmsGet = GhcModT get
|
||||
|
||||
gmsPut :: IOish m => GhcModState -> GhcModT m ()
|
||||
gmsPut = GhcModT . put
|
||||
|
||||
options :: IOish m => GhcModT m Options
|
||||
options = gmOptions <$> gmeAsk
|
||||
|
||||
cradle :: IOish m => GhcModT m Cradle
|
||||
cradle = gmCradle <$> gmeAsk
|
||||
|
||||
getCompilerMode :: IOish m => GhcModT m CompilerMode
|
||||
getCompilerMode = gmCompilerMode <$> gmsGet
|
||||
|
||||
setCompilerMode :: IOish m => CompilerMode -> GhcModT m ()
|
||||
setCompilerMode mode = (\s -> gmsPut s { gmCompilerMode = mode } ) =<< gmsGet
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
withOptions :: IOish m => (Options -> Options) -> GhcModT m a -> GhcModT m a
|
||||
withOptions changeOpt action = local changeEnv action
|
||||
where
|
||||
changeEnv e = e { gmOptions = changeOpt opt }
|
||||
where
|
||||
opt = gmOptions e
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
instance (MonadBaseControl IO m) => MonadBase IO (GhcModT m) where
|
||||
liftBase = GhcModT . liftBase
|
||||
|
||||
#if MIN_VERSION_monad_control(1,0,0)
|
||||
|
||||
instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where
|
||||
type StM (GhcModT m) a =
|
||||
StM (StateT GhcModState
|
||||
(ErrorT GhcModError
|
||||
(JournalT GhcModLog
|
||||
(ReaderT GhcModEnv m) ) ) ) a
|
||||
liftBaseWith f = GhcModT . liftBaseWith $ \runInBase ->
|
||||
f $ runInBase . unGhcModT
|
||||
|
||||
restoreM = GhcModT . restoreM
|
||||
{-# INLINE liftBaseWith #-}
|
||||
{-# INLINE restoreM #-}
|
||||
|
||||
#else
|
||||
|
||||
instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where
|
||||
newtype StM (GhcModT m) a = StGhcMod {
|
||||
unStGhcMod :: StM (StateT GhcModState
|
||||
(ErrorT GhcModError
|
||||
(JournalT GhcModLog
|
||||
(ReaderT GhcModEnv m) ) ) ) a }
|
||||
liftBaseWith f = GhcModT . liftBaseWith $ \runInBase ->
|
||||
f $ liftM StGhcMod . runInBase . unGhcModT
|
||||
|
||||
restoreM = GhcModT . restoreM . unStGhcMod
|
||||
{-# INLINE liftBaseWith #-}
|
||||
{-# INLINE restoreM #-}
|
||||
|
||||
#endif
|
||||
|
||||
-- GHC cannot prove the following instances to be decidable automatically using
|
||||
-- the FlexibleContexts extension as they violate the second Paterson Condition,
|
||||
-- namely that: The assertion has fewer constructors and variables (taken
|
||||
-- together and counting repetitions) than the head. Specifically the
|
||||
-- @MonadBaseControl IO m@ constraint is causing this violation.
|
||||
--
|
||||
-- Proof of termination:
|
||||
--
|
||||
-- Assuming all constraints containing the variable `m' exist and are decidable
|
||||
-- we show termination by manually replacing the current set of constraints with
|
||||
-- their own set of constraints and show that this, after a finite number of
|
||||
-- steps, results in the empty set, i.e. not having to check any more
|
||||
-- constraints.
|
||||
--
|
||||
-- We start by setting the constraints to be those immediate constraints of the
|
||||
-- instance declaration which cannot be proven decidable automatically for the
|
||||
-- type under consideration.
|
||||
--
|
||||
-- @
|
||||
-- { MonadBaseControl IO m }
|
||||
-- @
|
||||
--
|
||||
-- Classes used:
|
||||
--
|
||||
-- * @class MonadBase b m => MonadBaseControl b m@
|
||||
--
|
||||
-- @
|
||||
-- { MonadBase IO m }
|
||||
-- @
|
||||
--
|
||||
-- Classes used:
|
||||
--
|
||||
-- * @class (Applicative b, Applicative m, Monad b, Monad m) => MonadBase b m@
|
||||
--
|
||||
-- @
|
||||
-- { Applicative IO, Applicative m, Monad IO, Monad m }
|
||||
-- @
|
||||
--
|
||||
-- Classes used:
|
||||
--
|
||||
-- * @class Monad m@
|
||||
-- * @class Applicative f => Functor f@
|
||||
--
|
||||
-- @
|
||||
-- { Functor m }
|
||||
-- @
|
||||
--
|
||||
-- Classes used:
|
||||
--
|
||||
-- * @class Functor f@
|
||||
--
|
||||
-- @
|
||||
-- { }
|
||||
-- @
|
||||
-- ∎
|
||||
|
||||
instance (Functor m, MonadIO m, MonadBaseControl IO m)
|
||||
=> GhcMonad (GhcModT m) where
|
||||
getSession = (liftIO . readIORef) . gmGhcSession =<< ask
|
||||
setSession a = (liftIO . flip writeIORef a) . gmGhcSession =<< ask
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 706
|
||||
instance (Functor m, MonadIO m, MonadBaseControl IO m)
|
||||
=> HasDynFlags (GhcModT m) where
|
||||
getDynFlags = getSessionDynFlags
|
||||
#endif
|
||||
|
||||
instance (MonadIO m, MonadBaseControl IO m)
|
||||
=> ExceptionMonad (GhcModT m) where
|
||||
gcatch act handler = control $ \run ->
|
||||
run act `gcatch` (run . handler)
|
||||
|
||||
gmask = liftBaseOp gmask . liftRestore
|
||||
where liftRestore f r = f $ liftBaseOp_ r
|
||||
runGhcModT'' r s a = do
|
||||
flip runReaderT r $ runJournalT $ runErrorT $ runStateT (unGhcModT a) s
|
||||
|
442
Language/Haskell/GhcMod/Monad/Types.hs
Normal file
442
Language/Haskell/GhcMod/Monad/Types.hs
Normal 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
199
Language/Haskell/GhcMod/Output.hs
Normal 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 ++ ")"]
|
@ -1,21 +1,42 @@
|
||||
{-# LANGUAGE BangPatterns, TupleSections #-}
|
||||
module Language.Haskell.GhcMod.PathsAndFiles where
|
||||
-- ghc-mod: Making Haskell development *more* fun
|
||||
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
|
||||
--
|
||||
-- This program is free software: you can redistribute it and/or modify
|
||||
-- it under the terms of the GNU Affero General Public License as published by
|
||||
-- the Free Software Foundation, either version 3 of the License, or
|
||||
-- (at your option) any later version.
|
||||
--
|
||||
-- This program is distributed in the hope that it will be useful,
|
||||
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
-- GNU Affero General Public License for more details.
|
||||
--
|
||||
-- You should have received a copy of the GNU Affero General Public License
|
||||
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
module Language.Haskell.GhcMod.PathsAndFiles (
|
||||
module Language.Haskell.GhcMod.PathsAndFiles
|
||||
, module Language.Haskell.GhcMod.Caching
|
||||
) where
|
||||
|
||||
import Config (cProjectVersion)
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import Data.List
|
||||
import Data.Char
|
||||
import Data.Maybe
|
||||
import Data.Traversable (traverse)
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Data.Traversable hiding (mapM)
|
||||
import Distribution.Helper (buildPlatform)
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
import System.Process
|
||||
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Error
|
||||
import Language.Haskell.GhcMod.Caching
|
||||
import qualified Language.Haskell.GhcMod.Utils as U
|
||||
|
||||
import Distribution.Simple.BuildPaths (defaultDistPref)
|
||||
import Distribution.Simple.Configure (localBuildInfoFile)
|
||||
import Utils (mightExist)
|
||||
import Prelude
|
||||
|
||||
-- | Guaranteed to be a path to a directory with no trailing slash.
|
||||
type DirPath = FilePath
|
||||
@ -23,40 +44,111 @@ type DirPath = FilePath
|
||||
-- | Guaranteed to be the name of a file only (no slashes).
|
||||
type FileName = String
|
||||
|
||||
newtype UnString = UnString { unString :: String }
|
||||
|
||||
instance Show UnString where
|
||||
show = unString
|
||||
|
||||
instance Read UnString where
|
||||
readsPrec _ = \str -> [(UnString str, "")]
|
||||
|
||||
-- | @findCabalFiles dir@. Searches for a @.cabal@ files in @dir@'s parent
|
||||
-- directories. The first parent directory containing more than one cabal file
|
||||
-- is assumed to be the project directory. If only one cabal file exists in this
|
||||
-- directory it is returned otherwise @findCabalFiles@ throws 'GMENoCabalFile'
|
||||
-- or 'GMETooManyCabalFiles'
|
||||
findCabalFile :: FilePath -> IO (Maybe FilePath)
|
||||
findCabalFile directory = do
|
||||
-- Look for cabal files in @dir@ and all it's parent directories
|
||||
dcs <- getCabalFiles `zipMapM` parents directory
|
||||
-- Extract first non-empty list, which represents a directory with cabal
|
||||
-- files.
|
||||
case find (not . null) $ uncurry appendDir `map` dcs of
|
||||
Just [] -> throw $ GMENoCabalFile
|
||||
findCabalFile dir = do
|
||||
-- List of directories and all cabal file candidates
|
||||
dcs <- findFileInParentsP isCabalFile dir :: IO ([(DirPath, [FileName])])
|
||||
let css = uncurry appendDir `map` dcs :: [[FilePath]]
|
||||
case find (not . null) css of
|
||||
Nothing -> return Nothing
|
||||
Just cfs@(_:_:_) -> throw $ GMETooManyCabalFiles cfs
|
||||
a -> return $ head <$> a
|
||||
Just (a:_) -> return (Just a)
|
||||
Just [] -> error "findCabalFile"
|
||||
where
|
||||
appendDir :: DirPath -> [FileName] -> [FilePath]
|
||||
appendDir dir fs = (dir </>) `map` fs
|
||||
appendDir d fs = (d </>) `map` fs
|
||||
|
||||
-- | Get path to sandbox config file
|
||||
getSandboxDb :: FilePath
|
||||
-- ^ Path to the cabal package root directory (containing the
|
||||
-- @cabal.sandbox.config@ file)
|
||||
-> IO (Maybe GhcPkgDb)
|
||||
getSandboxDb d = do
|
||||
mConf <- traverse readFile =<< mightExist (d </> "cabal.sandbox.config")
|
||||
bp <- buildPlatform readProcess
|
||||
return $ PackageDb . fixPkgDbVer bp <$> (extractSandboxDbDir =<< mConf)
|
||||
|
||||
-- | @getCabalFiles dir@. Find all files ending in @.cabal@ in @dir@.
|
||||
getCabalFiles :: DirPath -> IO [FileName]
|
||||
getCabalFiles dir =
|
||||
filterM isCabalFile =<< getDirectoryContents dir
|
||||
where
|
||||
isCabalFile f = do
|
||||
exists <- doesFileExist $ dir </> f
|
||||
return (exists && takeExtension' f == ".cabal")
|
||||
fixPkgDbVer bp dir =
|
||||
case takeFileName dir == ghcSandboxPkgDbDir bp of
|
||||
True -> dir
|
||||
False -> takeDirectory dir </> ghcSandboxPkgDbDir bp
|
||||
|
||||
takeExtension' p = if takeFileName p == takeExtension p
|
||||
then ""
|
||||
-- | Extract the sandbox package db directory from the cabal.sandbox.config
|
||||
-- file. Exception is thrown if the sandbox config file is broken.
|
||||
extractSandboxDbDir :: String -> Maybe FilePath
|
||||
extractSandboxDbDir conf = extractValue <$> parse conf
|
||||
where
|
||||
key = "package-db:"
|
||||
keyLen = length key
|
||||
|
||||
parse = listToMaybe . filter (key `isPrefixOf`) . lines
|
||||
extractValue = U.dropWhileEnd isSpace . dropWhile isSpace . drop keyLen
|
||||
|
||||
|
||||
-- |
|
||||
-- >>> isCabalFile "/home/user/.cabal"
|
||||
-- False
|
||||
isCabalFile :: FilePath -> Bool
|
||||
isCabalFile f = takeExtension' f == ".cabal"
|
||||
|
||||
-- |
|
||||
-- >>> takeExtension' "/some/dir/bla.cabal"
|
||||
-- ".cabal"
|
||||
--
|
||||
-- >>> takeExtension' "some/reldir/bla.cabal"
|
||||
-- ".cabal"
|
||||
--
|
||||
-- >>> takeExtension' "bla.cabal"
|
||||
-- ".cabal"
|
||||
--
|
||||
-- >>> takeExtension' ".cabal"
|
||||
-- ""
|
||||
takeExtension' :: FilePath -> String
|
||||
takeExtension' p =
|
||||
if takeFileName p == takeExtension p
|
||||
then "" -- just ".cabal" is not a valid cabal file
|
||||
else takeExtension p
|
||||
|
||||
-- | @findFileInParentsP p dir@ Look for files satisfying @p@ in @dir@ and all
|
||||
-- it's parent directories.
|
||||
findFileInParentsP :: (FilePath -> Bool) -> FilePath
|
||||
-> IO [(DirPath, [FileName])]
|
||||
findFileInParentsP p dir =
|
||||
getFilesP p `zipMapM` parents dir
|
||||
|
||||
-- | @getFilesP p dir@. Find all __files__ satisfying @p@ in @.cabal@ in @dir@.
|
||||
getFilesP :: (FilePath -> Bool) -> DirPath -> IO [FileName]
|
||||
getFilesP p dir = filterM p' =<< getDirectoryContents dir
|
||||
where
|
||||
p' fn = do
|
||||
(p fn && ) <$> doesFileExist (dir </> fn)
|
||||
|
||||
findCabalSandboxDir :: FilePath -> IO (Maybe FilePath)
|
||||
findCabalSandboxDir dir = do
|
||||
dss <- findFileInParentsP isSandboxConfig dir
|
||||
return $ case find (not . null . snd) $ dss of
|
||||
Just (sbDir, _:_) -> Just sbDir
|
||||
_ -> Nothing
|
||||
|
||||
where
|
||||
isSandboxConfig = (==sandboxConfigFile)
|
||||
|
||||
zipMapM :: Monad m => (a -> m c) -> [a] -> m [(a,c)]
|
||||
zipMapM f as = mapM (\a -> liftM (a,) $ f a) as
|
||||
zipMapM f as = mapM (\a -> liftM ((,) a) $ f a) as
|
||||
|
||||
-- | @parents dir@. Returns all parent directories of @dir@ including @dir@.
|
||||
--
|
||||
@ -86,31 +178,48 @@ parents dir' =
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | Get path to sandbox config file
|
||||
getSandboxDb :: FilePath -- ^ Path to the cabal package root directory
|
||||
-- (containing the @cabal.sandbox.config@ file)
|
||||
-> IO (Maybe FilePath)
|
||||
getSandboxDb d = do
|
||||
mConf <- traverse readFile =<< U.mightExist (d </> "cabal.sandbox.config")
|
||||
return $ extractSandboxDbDir =<< mConf
|
||||
|
||||
-- | Extract the sandbox package db directory from the cabal.sandbox.config file.
|
||||
-- Exception is thrown if the sandbox config file is broken.
|
||||
extractSandboxDbDir :: String -> Maybe FilePath
|
||||
extractSandboxDbDir conf = extractValue <$> parse conf
|
||||
where
|
||||
key = "package-db:"
|
||||
keyLen = length key
|
||||
|
||||
parse = listToMaybe . filter (key `isPrefixOf`) . lines
|
||||
extractValue = U.dropWhileEnd isSpace . dropWhile isSpace . drop keyLen
|
||||
|
||||
setupConfigFile :: Cradle -> FilePath
|
||||
setupConfigFile crdl = cradleRootDir crdl </> setupConfigPath
|
||||
|
||||
sandboxConfigFile :: FilePath
|
||||
sandboxConfigFile = "cabal.sandbox.config"
|
||||
|
||||
-- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@
|
||||
setupConfigPath :: FilePath
|
||||
setupConfigPath = localBuildInfoFile defaultDistPref
|
||||
setupConfigPath = "dist/setup-config" -- localBuildInfoFile defaultDistPref
|
||||
|
||||
macrosHeaderPath :: FilePath
|
||||
macrosHeaderPath = "dist/build/autogen/cabal_macros.h"
|
||||
|
||||
ghcSandboxPkgDbDir :: String -> String
|
||||
ghcSandboxPkgDbDir buildPlatf = do
|
||||
buildPlatf ++ "-ghc-" ++ cProjectVersion ++ "-packages.conf.d"
|
||||
|
||||
packageCache :: String
|
||||
packageCache = "package.cache"
|
||||
|
||||
-- | Filename of the symbol table cache file.
|
||||
symbolCache :: Cradle -> FilePath
|
||||
symbolCache crdl = cradleTempDir crdl </> symbolCacheFile
|
||||
|
||||
symbolCacheFile :: String
|
||||
symbolCacheFile = "ghc-mod.symbol-cache"
|
||||
|
||||
resolvedComponentsCacheFile :: String
|
||||
resolvedComponentsCacheFile = setupConfigPath <.> "ghc-mod.resolved-components"
|
||||
|
||||
cabalHelperCacheFile :: String
|
||||
cabalHelperCacheFile = setupConfigPath <.> "ghc-mod.cabal-components"
|
||||
|
||||
mergedPkgOptsCacheFile :: String
|
||||
mergedPkgOptsCacheFile = setupConfigPath <.> "ghc-mod.package-options"
|
||||
|
||||
pkgDbStackCacheFile :: String
|
||||
pkgDbStackCacheFile = setupConfigPath <.> "ghc-mod.package-db-stack"
|
||||
|
||||
-- | @findCustomPackageDbFile dir@. Searches for a @.ghc-mod.cradle@ file in @dir@.
|
||||
-- If it exists in the given directory it is returned otherwise @findCradleFile@ returns @Nothing@
|
||||
findCustomPackageDbFile :: FilePath -> IO (Maybe FilePath)
|
||||
findCustomPackageDbFile directory = do
|
||||
let path = directory </> "ghc-mod.package-db-stack"
|
||||
mightExist path
|
||||
|
@ -5,22 +5,23 @@ import Language.Haskell.GhcMod.GhcPkg
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.Utils
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Applicative
|
||||
import Prelude
|
||||
|
||||
-- | Obtaining the package name and the doc path of a module.
|
||||
pkgDoc :: IOish m => String -> GhcModT m String
|
||||
pkgDoc mdl = do
|
||||
c <- cradle
|
||||
pkg <- trim <$> readProcess' "ghc-pkg" (toModuleOpts c)
|
||||
pkgDbStack <- getPackageDbStack
|
||||
pkg <- liftIO $ trim <$> readProcess "ghc-pkg" (toModuleOpts pkgDbStack) ""
|
||||
if pkg == "" then
|
||||
return "\n"
|
||||
else do
|
||||
htmlpath <- readProcess' "ghc-pkg" (toDocDirOpts pkg c)
|
||||
htmlpath <- liftIO $ readProcess "ghc-pkg" (toDocDirOpts pkg pkgDbStack) ""
|
||||
let ret = pkg ++ " " ++ drop 14 htmlpath
|
||||
return ret
|
||||
where
|
||||
toModuleOpts c = ["find-module", mdl, "--simple-output"]
|
||||
++ ghcPkgDbStackOpts (cradlePkgDbStack c)
|
||||
toDocDirOpts pkg c = ["field", pkg, "haddock-html"]
|
||||
++ ghcPkgDbStackOpts (cradlePkgDbStack c)
|
||||
toModuleOpts dbs = ["find-module", mdl, "--simple-output"]
|
||||
++ ghcPkgDbStackOpts dbs
|
||||
toDocDirOpts pkg dbs = ["field", pkg, "haddock-html"]
|
||||
++ ghcPkgDbStackOpts dbs
|
||||
trim = takeWhile (`notElem` " \n")
|
||||
|
69
Language/Haskell/GhcMod/Pretty.hs
Normal file
69
Language/Haskell/GhcMod/Pretty.hs
Normal 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
|
@ -3,7 +3,7 @@
|
||||
|
||||
module Language.Haskell.GhcMod.SrcUtils where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Applicative
|
||||
import CoreUtils (exprType)
|
||||
import Data.Generics
|
||||
import Data.Maybe (fromMaybe)
|
||||
@ -13,15 +13,13 @@ import qualified GHC as G
|
||||
import GHC.SYB.Utils (Stage(..), everythingStaged)
|
||||
import GhcMonad
|
||||
import qualified Language.Haskell.Exts.Annotated as HE
|
||||
import Language.Haskell.GhcMod.Doc (showOneLine, getStyle)
|
||||
import Language.Haskell.GhcMod.DynFlags
|
||||
import Language.Haskell.GhcMod.Gap (HasType(..), setWarnTypedHoles, setDeferTypeErrors)
|
||||
import Language.Haskell.GhcMod.Doc
|
||||
import Language.Haskell.GhcMod.Gap
|
||||
import qualified Language.Haskell.GhcMod.Gap as Gap
|
||||
import Language.Haskell.GhcMod.Monad (IOish, GhcModT)
|
||||
import Language.Haskell.GhcMod.Target (setTargetFiles)
|
||||
import OccName (OccName)
|
||||
import Outputable (PprStyle)
|
||||
import TcHsSyn (hsPatType)
|
||||
import Prelude
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
@ -83,22 +81,6 @@ typeSigInRangeHE _ _ _= False
|
||||
pretty :: DynFlags -> PprStyle -> Type -> String
|
||||
pretty dflag style = showOneLine dflag style . Gap.typeForUser
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
inModuleContext :: IOish m
|
||||
=> FilePath
|
||||
-> (DynFlags -> PprStyle -> GhcModT m a)
|
||||
-> GhcModT m a
|
||||
inModuleContext file action =
|
||||
withDynFlags (setWarnTypedHoles . setDeferTypeErrors . setNoWarningFlags) $ do
|
||||
setTargetFiles [file]
|
||||
Gap.withContext $ do
|
||||
dflag <- G.getSessionDynFlags
|
||||
style <- getStyle
|
||||
action dflag style
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
showName :: DynFlags -> PprStyle -> G.Name -> String
|
||||
showName dflag style name = showOneLine dflag style $ Gap.nameForUser name
|
||||
|
||||
|
@ -1,60 +1,486 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Language.Haskell.GhcMod.Target (
|
||||
setTargetFiles
|
||||
) where
|
||||
-- ghc-mod: Making Haskell development *more* fun
|
||||
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
|
||||
--
|
||||
-- This program is free software: you can redistribute it and/or modify
|
||||
-- it under the terms of the GNU Affero General Public License as published by
|
||||
-- the Free Software Foundation, either version 3 of the License, or
|
||||
-- (at your option) any later version.
|
||||
--
|
||||
-- This program is distributed in the hope that it will be useful,
|
||||
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
-- GNU Affero General Public License for more details.
|
||||
--
|
||||
-- You should have received a copy of the GNU Affero General Public License
|
||||
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
{-# LANGUAGE CPP, ViewPatterns, NamedFieldPuns, RankNTypes #-}
|
||||
module Language.Haskell.GhcMod.Target where
|
||||
|
||||
import Control.Arrow
|
||||
import Control.Applicative
|
||||
import Control.Category ((.))
|
||||
import Control.Monad.Reader (runReaderT)
|
||||
import GHC
|
||||
import GHC.Paths (libdir)
|
||||
import StaticFlags
|
||||
import SysTools
|
||||
import DynFlags
|
||||
import HscMain
|
||||
import HscTypes
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Monad (forM, void, (>=>))
|
||||
import DynFlags (ExtensionFlag(..), xopt)
|
||||
import GHC (LoadHowMuch(..))
|
||||
import qualified GHC as G
|
||||
import Language.Haskell.GhcMod.DynFlags
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.Monad.Types
|
||||
import Language.Haskell.GhcMod.CabalHelper
|
||||
import Language.Haskell.GhcMod.HomeModuleGraph
|
||||
import Language.Haskell.GhcMod.PathsAndFiles
|
||||
import Language.Haskell.GhcMod.GhcPkg
|
||||
import Language.Haskell.GhcMod.Error
|
||||
import Language.Haskell.GhcMod.Logging
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Utils as U
|
||||
|
||||
|
||||
import Data.Maybe
|
||||
import Data.Monoid as Monoid
|
||||
import Data.Either
|
||||
import Data.Foldable as Foldable (foldrM)
|
||||
import qualified Data.Foldable as Foldable
|
||||
import Data.Traversable hiding (mapM, forM)
|
||||
import Data.IORef
|
||||
import Data.List
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Distribution.Helper
|
||||
import Prelude hiding ((.))
|
||||
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
|
||||
withLightHscEnv :: forall m a. IOish m
|
||||
=> [GHCOption] -> (HscEnv -> m a) -> m a
|
||||
withLightHscEnv opts action = gbracket initEnv teardownEnv action
|
||||
where
|
||||
teardownEnv :: HscEnv -> m ()
|
||||
teardownEnv env = liftIO $ do
|
||||
let dflags = hsc_dflags env
|
||||
cleanTempFiles dflags
|
||||
cleanTempDirs dflags
|
||||
|
||||
initEnv :: m HscEnv
|
||||
initEnv = liftIO $ do
|
||||
initStaticOpts
|
||||
settings <- initSysTools (Just libdir)
|
||||
dflags <- initDynFlags (defaultDynFlags settings)
|
||||
env <- newHscEnv dflags
|
||||
dflags' <- runLightGhc env $ do
|
||||
-- HomeModuleGraph and probably all other clients get into all sorts of
|
||||
-- trouble if the package state isn't initialized here
|
||||
_ <- setSessionDynFlags =<< addCmdOpts opts =<< getSessionDynFlags
|
||||
getSessionDynFlags
|
||||
newHscEnv dflags'
|
||||
|
||||
runLightGhc :: HscEnv -> LightGhc a -> IO a
|
||||
runLightGhc env action = do
|
||||
renv <- newIORef env
|
||||
flip runReaderT renv $ unLightGhc action
|
||||
|
||||
runGmPkgGhc :: (IOish m, GmEnv m, GmState m, GmLog m) => LightGhc a -> m a
|
||||
runGmPkgGhc action = do
|
||||
pkgOpts <- packageGhcOptions
|
||||
withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action
|
||||
|
||||
initSession :: IOish m
|
||||
=> [GHCOption] -> (DynFlags -> Ghc DynFlags) -> GhcModT m ()
|
||||
initSession opts mdf = do
|
||||
s <- gmsGet
|
||||
case gmGhcSession s of
|
||||
Just GmGhcSession {..} -> when (gmgsOptions /= opts) $ putNewSession s
|
||||
Nothing -> putNewSession s
|
||||
|
||||
where
|
||||
putNewSession s = do
|
||||
rghc <- (liftIO . newIORef =<< newSession =<< cradle)
|
||||
gmsPut s { gmGhcSession = Just $ GmGhcSession opts rghc }
|
||||
|
||||
newSession Cradle { cradleTempDir } = liftIO $ do
|
||||
runGhc (Just libdir) $ do
|
||||
let setDf df = setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df)
|
||||
_ <- setSessionDynFlags =<< setDf =<< getSessionDynFlags
|
||||
getSession
|
||||
|
||||
-- | Drop the currently active GHC session, the next that requires a GHC session
|
||||
-- will initialize a new one.
|
||||
dropSession :: IOish m => GhcModT m ()
|
||||
dropSession = do
|
||||
s <- gmsGet
|
||||
case gmGhcSession s of
|
||||
Just (GmGhcSession _opts ref) -> do
|
||||
-- TODO: This is still not enough, there seem to still be references to
|
||||
-- GHC's state around afterwards.
|
||||
liftIO $ writeIORef ref (error "HscEnv: session was dropped")
|
||||
-- Not available on ghc<7.8; didn't really help anyways
|
||||
-- liftIO $ setUnsafeGlobalDynFlags (error "DynFlags: session was dropped")
|
||||
gmsPut s { gmGhcSession = Nothing }
|
||||
|
||||
Nothing -> return ()
|
||||
|
||||
|
||||
runGmlT :: IOish m => [Either FilePath ModuleName] -> GmlT m a -> GhcModT m a
|
||||
runGmlT fns action = runGmlT' fns return action
|
||||
|
||||
runGmlT' :: IOish m
|
||||
=> [Either FilePath ModuleName]
|
||||
-> (DynFlags -> Ghc DynFlags)
|
||||
-> GmlT m a
|
||||
-> GhcModT m a
|
||||
runGmlT' fns mdf action = runGmlTWith fns mdf id action
|
||||
|
||||
runGmlTWith :: IOish m
|
||||
=> [Either FilePath ModuleName]
|
||||
-> (DynFlags -> Ghc DynFlags)
|
||||
-> (GmlT m a -> GmlT m b)
|
||||
-> GmlT m a
|
||||
-> GhcModT m b
|
||||
runGmlTWith efnmns' mdf wrapper action = do
|
||||
crdl <- cradle
|
||||
Options { ghcUserOptions } <- options
|
||||
|
||||
let (fns, mns) = partitionEithers efnmns'
|
||||
ccfns = map (cradleCurrentDir crdl </>) fns
|
||||
cfns <- liftIO $ mapM canonicalizePath ccfns
|
||||
let serfnmn = Set.fromList $ map Right mns ++ map Left cfns
|
||||
opts <- targetGhcOptions crdl serfnmn
|
||||
let opts' = opts ++ ["-O0"] ++ ghcUserOptions
|
||||
|
||||
gmVomit
|
||||
"session-ghc-options"
|
||||
(text "Initializing GHC session with following options")
|
||||
(intercalate " " $ map (("\""++) . (++"\"")) opts')
|
||||
|
||||
initSession opts' $
|
||||
setModeSimple >>> setEmptyLogger >>> mdf
|
||||
|
||||
let rfns = map (makeRelative $ cradleRootDir crdl) cfns
|
||||
|
||||
unGmlT $ wrapper $ do
|
||||
loadTargets (map moduleNameString mns ++ rfns)
|
||||
action
|
||||
|
||||
targetGhcOptions :: forall m. IOish m
|
||||
=> Cradle
|
||||
-> Set (Either FilePath ModuleName)
|
||||
-> GhcModT m [GHCOption]
|
||||
targetGhcOptions crdl sefnmn = do
|
||||
when (Set.null sefnmn) $ error "targetGhcOptions: no targets given"
|
||||
|
||||
case cradleProjectType crdl of
|
||||
CabalProject -> cabalOpts crdl
|
||||
_ -> sandboxOpts crdl
|
||||
where
|
||||
zipMap f l = l `zip` (f `map` l)
|
||||
|
||||
cabalOpts :: Cradle -> GhcModT m [String]
|
||||
cabalOpts Cradle{..} = do
|
||||
mcs <- cabalResolvedComponents
|
||||
|
||||
let mdlcs = moduleComponents mcs `zipMap` Set.toList sefnmn
|
||||
candidates = findCandidates $ map snd mdlcs
|
||||
|
||||
let noCandidates = Set.null candidates
|
||||
noModuleHasAnyAssignment = all (Set.null . snd) mdlcs
|
||||
|
||||
if noCandidates && noModuleHasAnyAssignment
|
||||
then do
|
||||
-- First component should be ChLibName, if no lib will take lexically first exe.
|
||||
let cns = filter (/= ChSetupHsName) $ Map.keys mcs
|
||||
|
||||
gmLog GmWarning "" $ strDoc $ "Could not find a component assignment, falling back to picking library component in cabal file."
|
||||
return $ gmcGhcOpts $ fromJust $ Map.lookup (head cns) mcs
|
||||
else do
|
||||
when noCandidates $
|
||||
throwError $ GMECabalCompAssignment mdlcs
|
||||
|
||||
let cn = pickComponent candidates
|
||||
return $ gmcGhcOpts $ fromJust $ Map.lookup cn mcs
|
||||
|
||||
resolvedComponentsCache :: IOish m => Cached (GhcModT m) GhcModState
|
||||
[GmComponent 'GMCRaw (Set.Set ModulePath)]
|
||||
(Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath)))
|
||||
resolvedComponentsCache = Cached {
|
||||
cacheLens = Just (lGmcResolvedComponents . lGmCaches),
|
||||
cacheFile = resolvedComponentsCacheFile,
|
||||
cachedAction = \tcfs comps ma -> do
|
||||
Cradle {..} <- cradle
|
||||
let iifsM = invalidatingInputFiles tcfs
|
||||
mums :: Maybe [Either FilePath ModuleName]
|
||||
mums =
|
||||
case iifsM of
|
||||
Nothing -> Nothing
|
||||
Just iifs ->
|
||||
let
|
||||
filterOutSetupCfg =
|
||||
filter (/= cradleRootDir </> setupConfigPath)
|
||||
changedFiles = filterOutSetupCfg iifs
|
||||
in if null changedFiles
|
||||
then Nothing
|
||||
else Just $ map Left changedFiles
|
||||
setupChanged = maybe False
|
||||
(elem $ cradleRootDir </> setupConfigPath)
|
||||
iifsM
|
||||
case (setupChanged, ma) of
|
||||
(False, Just mcs) -> gmsGet >>= \s -> gmsPut s { gmComponents = mcs }
|
||||
_ -> return ()
|
||||
|
||||
let mdesc (Left f) = "file:" ++ f
|
||||
mdesc (Right mn) = "module:" ++ moduleNameString mn
|
||||
|
||||
changed = map (text . mdesc) $ Foldable.concat mums
|
||||
changedDoc | [] <- changed = text "none"
|
||||
| otherwise = sep changed
|
||||
|
||||
gmLog GmDebug "resolvedComponentsCache" $
|
||||
text "files changed" <+>: changedDoc
|
||||
|
||||
mcs <- resolveGmComponents mums comps
|
||||
return (setupConfigPath:flatten mcs , mcs)
|
||||
}
|
||||
|
||||
where
|
||||
flatten :: Map.Map ChComponentName (GmComponent t (Set.Set ModulePath))
|
||||
-> [FilePath]
|
||||
flatten = Map.elems
|
||||
>>> map (gmcHomeModuleGraph >>> gmgGraph
|
||||
>>> Map.elems
|
||||
>>> map (Set.map mpPath)
|
||||
>>> Set.unions
|
||||
)
|
||||
>>> Set.unions
|
||||
>>> Set.toList
|
||||
|
||||
moduleComponents :: Map ChComponentName (GmComponent t (Set ModulePath))
|
||||
-> Either FilePath ModuleName
|
||||
-> Set ChComponentName
|
||||
moduleComponents m efnmn =
|
||||
foldr' Set.empty m $ \c s ->
|
||||
let
|
||||
memb =
|
||||
case efnmn of
|
||||
Left fn -> fn `Set.member` Set.map mpPath (smp c)
|
||||
Right mn -> mn `Set.member` Set.map mpModule (smp c)
|
||||
in if memb
|
||||
then Set.insert (gmcName c) s
|
||||
else s
|
||||
where
|
||||
smp c = Map.keysSet $ gmgGraph $ gmcHomeModuleGraph c
|
||||
|
||||
foldr' b as f = Map.foldr f b as
|
||||
|
||||
|
||||
findCandidates :: [Set ChComponentName] -> Set ChComponentName
|
||||
findCandidates [] = Set.empty
|
||||
findCandidates scns = foldl1 Set.intersection scns
|
||||
|
||||
pickComponent :: Set ChComponentName -> ChComponentName
|
||||
pickComponent scn = Set.findMin scn
|
||||
|
||||
packageGhcOptions :: (Applicative m, IOish m, GmEnv m, GmState m, GmLog m)
|
||||
=> m [GHCOption]
|
||||
packageGhcOptions = do
|
||||
crdl <- cradle
|
||||
case cradleProjectType crdl of
|
||||
CabalProject -> getGhcMergedPkgOptions
|
||||
_ -> sandboxOpts crdl
|
||||
|
||||
-- also works for plain projects!
|
||||
sandboxOpts :: MonadIO m => Cradle -> m [String]
|
||||
sandboxOpts crdl = do
|
||||
pkgDbStack <- liftIO $ getSandboxPackageDbStack $ cradleRootDir crdl
|
||||
let pkgOpts = ghcDbStackOpts pkgDbStack
|
||||
return $ ["-i" ++ d | d <- [wdir,rdir]] ++ pkgOpts ++ ["-Wall"]
|
||||
where
|
||||
(wdir, rdir) = (cradleCurrentDir crdl, cradleRootDir crdl)
|
||||
|
||||
getSandboxPackageDbStack :: FilePath
|
||||
-- ^ Project Directory (where the cabal.sandbox.config
|
||||
-- file would be if it exists)
|
||||
-> IO [GhcPkgDb]
|
||||
getSandboxPackageDbStack cdir =
|
||||
([GlobalDb] ++) . maybe [UserDb] return <$> getSandboxDb cdir
|
||||
|
||||
resolveGmComponent :: (IOish m, GmLog m, GmEnv m)
|
||||
=> Maybe [CompilationUnit] -- ^ Updated modules
|
||||
-> GmComponent 'GMCRaw (Set ModulePath)
|
||||
-> m (GmComponent 'GMCResolved (Set ModulePath))
|
||||
resolveGmComponent mums c@GmComponent {..} = do
|
||||
withLightHscEnv ghcOpts $ \env -> do
|
||||
let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs
|
||||
let mg = gmcHomeModuleGraph
|
||||
let simp = gmcEntrypoints
|
||||
sump <- case mums of
|
||||
Nothing -> return simp
|
||||
Just ums ->
|
||||
Set.fromList . catMaybes <$>
|
||||
mapM (resolveModule env srcDirs) ums
|
||||
|
||||
mg' <- canonicalizeModuleGraph =<< updateHomeModuleGraph env mg simp sump
|
||||
|
||||
return $ c { gmcEntrypoints = simp, gmcHomeModuleGraph = mg' }
|
||||
|
||||
where ghcOpts = concat [
|
||||
gmcGhcSrcOpts,
|
||||
gmcGhcLangOpts,
|
||||
[ "-optP-include", "-optP" ++ macrosHeaderPath ]
|
||||
]
|
||||
|
||||
resolveEntrypoint :: (IOish m, GmEnv m, GmLog m)
|
||||
=> Cradle
|
||||
-> GmComponent 'GMCRaw ChEntrypoint
|
||||
-> m (GmComponent 'GMCRaw (Set ModulePath))
|
||||
resolveEntrypoint Cradle {..} c@GmComponent {..} = do
|
||||
withLightHscEnv gmcGhcSrcOpts $ \env -> do
|
||||
let srcDirs = if null gmcSourceDirs then [""] else gmcSourceDirs
|
||||
eps <- liftIO $ resolveChEntrypoints cradleRootDir gmcEntrypoints
|
||||
rms <- resolveModule env srcDirs `mapM` eps
|
||||
return c { gmcEntrypoints = Set.fromList $ catMaybes rms }
|
||||
|
||||
-- TODO: remember that he file from `main-is:` is always module `Main` and let
|
||||
-- ghc do the warning about it. Right now we run that module through
|
||||
-- resolveModule like any other
|
||||
resolveChEntrypoints :: FilePath -> ChEntrypoint -> IO [CompilationUnit]
|
||||
resolveChEntrypoints _ (ChLibEntrypoint em om) =
|
||||
return $ map (Right . chModToMod) (em ++ om)
|
||||
|
||||
resolveChEntrypoints _ (ChExeEntrypoint main om) =
|
||||
return $ [Left main] ++ map (Right . chModToMod) om
|
||||
|
||||
resolveChEntrypoints srcDir ChSetupEntrypoint = do
|
||||
shs <- doesFileExist (srcDir </> "Setup.hs")
|
||||
slhs <- doesFileExist (srcDir </> "Setup.lhs")
|
||||
return $ case (shs, slhs) of
|
||||
(True, _) -> [Left "Setup.hs"]
|
||||
(_, True) -> [Left "Setup.lhs"]
|
||||
(False, False) -> []
|
||||
|
||||
chModToMod :: ChModuleName -> ModuleName
|
||||
chModToMod (ChModuleName mn) = mkModuleName mn
|
||||
|
||||
resolveModule :: (MonadIO m, GmEnv m, GmLog m) =>
|
||||
HscEnv -> [FilePath] -> CompilationUnit -> m (Maybe ModulePath)
|
||||
resolveModule env _srcDirs (Right mn) =
|
||||
liftIO $ traverse canonicalizeModulePath =<< findModulePath env mn
|
||||
resolveModule env srcDirs (Left fn') = do
|
||||
mfn <- liftIO $ findFile' srcDirs fn'
|
||||
case mfn of
|
||||
Nothing -> return Nothing
|
||||
Just fn'' -> do
|
||||
fn <- liftIO $ canonicalizePath fn''
|
||||
emn <- liftIO $ fileModuleName env fn
|
||||
case emn of
|
||||
Left errs -> do
|
||||
gmLog GmWarning ("resolveModule " ++ show fn) $
|
||||
Monoid.mempty $+$ (vcat $ map text errs)
|
||||
return Nothing -- TODO: should expose these errors otherwise
|
||||
-- modules with preprocessor/parse errors are
|
||||
-- going to be missing
|
||||
Right mmn -> return $ Just $
|
||||
case mmn of
|
||||
Nothing -> mkMainModulePath fn
|
||||
Just mn -> ModulePath mn fn
|
||||
where
|
||||
-- needed for ghc 7.4
|
||||
findFile' dirs file =
|
||||
getFirst . mconcat <$> mapM (fmap First . mightExist . (</>file)) dirs
|
||||
|
||||
-- fileModuleName fn (dir:dirs)
|
||||
-- | makeRelative dir fn /= fn
|
||||
|
||||
type CompilationUnit = Either FilePath ModuleName
|
||||
|
||||
resolveGmComponents :: (IOish m, GmState m, GmLog m, GmEnv m)
|
||||
=> Maybe [CompilationUnit]
|
||||
-- ^ Updated modules
|
||||
-> [GmComponent 'GMCRaw (Set ModulePath)]
|
||||
-> m (Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath)))
|
||||
resolveGmComponents mumns cs = do
|
||||
s <- gmsGet
|
||||
m' <- foldrM' (gmComponents s) cs $ \c m -> do
|
||||
case Map.lookup (gmcName c) m of
|
||||
Nothing -> insertUpdated m c
|
||||
Just c' -> if same gmcRawEntrypoints c c' && same gmcGhcSrcOpts c c'
|
||||
then return m
|
||||
else insertUpdated m c
|
||||
gmsPut s { gmComponents = m' }
|
||||
return m'
|
||||
|
||||
where
|
||||
foldrM' b fa f = foldrM f b fa
|
||||
insertUpdated m c = do
|
||||
rc <- resolveGmComponent mumns c
|
||||
return $ Map.insert (gmcName rc) rc m
|
||||
|
||||
same :: Eq b
|
||||
=> (forall t a. GmComponent t a -> b)
|
||||
-> GmComponent u c -> GmComponent v d -> Bool
|
||||
same f a b = (f a) == (f b)
|
||||
|
||||
-- | Set the files as targets and load them.
|
||||
setTargetFiles :: IOish m => [FilePath] -> GhcModT m ()
|
||||
setTargetFiles files = do
|
||||
targets <- forM files $ \file -> G.guessTarget file Nothing
|
||||
G.setTargets targets
|
||||
loadTargets :: IOish m => [String] -> GmlT m ()
|
||||
loadTargets filesOrModules = do
|
||||
gmLog GmDebug "loadTargets" $
|
||||
text "Loading" <+>: fsep (map text filesOrModules)
|
||||
|
||||
targets <- forM filesOrModules (flip guessTarget Nothing)
|
||||
setTargets targets
|
||||
|
||||
mode <- getCompilerMode
|
||||
if mode == Intelligent then
|
||||
loadTargets Intelligent
|
||||
if mode == Intelligent
|
||||
then loadTargets' Intelligent
|
||||
else do
|
||||
mdls <- G.depanal [] False
|
||||
mdls <- depanal [] False
|
||||
let fallback = needsFallback mdls
|
||||
if fallback then do
|
||||
resetTargets targets
|
||||
setIntelligent
|
||||
loadTargets Intelligent
|
||||
gmLog GmInfo "loadTargets" $
|
||||
text "Target needs interpeter, switching to LinkInMemory/HscInterpreted. Perfectly normal if anything is using TemplateHaskell, QuasiQuotes or PatternSynonyms."
|
||||
loadTargets' Intelligent
|
||||
else
|
||||
loadTargets Simple
|
||||
loadTargets' Simple
|
||||
where
|
||||
loadTargets Simple = do
|
||||
-- Reporting error A and error B
|
||||
void $ G.load LoadAllTargets
|
||||
mss <- filter (\x -> G.ms_hspp_file x `elem` files) <$> G.getModuleGraph
|
||||
-- Reporting error B and error C
|
||||
mapM_ (G.parseModule >=> G.typecheckModule >=> G.desugarModule) mss
|
||||
-- Error B duplicates. But we cannot ignore both error reportings,
|
||||
-- sigh. So, the logger makes log messages unique by itself.
|
||||
loadTargets Intelligent = do
|
||||
df <- G.getSessionDynFlags
|
||||
void $ G.setSessionDynFlags (setModeIntelligent df)
|
||||
void $ G.load LoadAllTargets
|
||||
loadTargets' Simple = do
|
||||
void $ load LoadAllTargets
|
||||
mapM_ (parseModule >=> typecheckModule >=> desugarModule) =<< getModuleGraph
|
||||
|
||||
loadTargets' Intelligent = do
|
||||
df <- getSessionDynFlags
|
||||
void $ setSessionDynFlags (setModeIntelligent df)
|
||||
void $ load LoadAllTargets
|
||||
|
||||
resetTargets targets = do
|
||||
G.setTargets []
|
||||
void $ G.load LoadAllTargets
|
||||
G.setTargets targets
|
||||
setTargets []
|
||||
void $ load LoadAllTargets
|
||||
setTargets targets
|
||||
|
||||
setIntelligent = do
|
||||
newdf <- setModeIntelligent <$> G.getSessionDynFlags
|
||||
void $ G.setSessionDynFlags newdf
|
||||
newdf <- setModeIntelligent <$> getSessionDynFlags
|
||||
void $ setSessionDynFlags newdf
|
||||
setCompilerMode Intelligent
|
||||
|
||||
needsFallback :: G.ModuleGraph -> Bool
|
||||
needsFallback :: ModuleGraph -> Bool
|
||||
needsFallback = any $ \ms ->
|
||||
let df = G.ms_hspp_opts ms in
|
||||
let df = ms_hspp_opts ms in
|
||||
Opt_TemplateHaskell `xopt` df
|
||||
|| Opt_QuasiQuotes `xopt` df
|
||||
#if __GLASGOW_HASKELL__ >= 708
|
||||
|| (Opt_PatternSynonyms `xopt` df)
|
||||
#endif
|
||||
|
||||
cabalResolvedComponents :: (IOish m) =>
|
||||
GhcModT m (Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath)))
|
||||
cabalResolvedComponents = do
|
||||
crdl@(Cradle{..}) <- cradle
|
||||
comps <- mapM (resolveEntrypoint crdl) =<< getComponents
|
||||
cached cradleRootDir resolvedComponentsCache comps
|
||||
|
@ -1,12 +1,45 @@
|
||||
module Language.Haskell.GhcMod.Types where
|
||||
{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, DeriveGeneric,
|
||||
StandaloneDeriving, DefaultSignatures, FlexibleInstances, TemplateHaskell #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}
|
||||
module Language.Haskell.GhcMod.Types (
|
||||
module Language.Haskell.GhcMod.Types
|
||||
, ModuleName
|
||||
, mkModuleName
|
||||
, moduleNameString
|
||||
) where
|
||||
|
||||
import Control.Monad.Trans.Control (MonadBaseControl)
|
||||
import Control.Monad.Error (Error(..))
|
||||
import qualified Control.Monad.IO.Class as MTL
|
||||
import Control.Exception (Exception)
|
||||
import Control.Applicative
|
||||
import Control.Concurrent
|
||||
import Control.Monad
|
||||
import Data.Serialize
|
||||
import Data.Version
|
||||
import Data.List (intercalate)
|
||||
import qualified Data.Map as M
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Monoid
|
||||
import Data.Maybe
|
||||
import Data.Typeable (Typeable)
|
||||
import Data.IORef
|
||||
import Data.Label.Derive
|
||||
import Distribution.Helper
|
||||
import Exception (ExceptionMonad)
|
||||
import MonadUtils (MonadIO)
|
||||
|
||||
#if __GLASGOW_HASKELL__ < 708
|
||||
import qualified MonadUtils as GHC (MonadIO(..))
|
||||
#endif
|
||||
import GHC (ModuleName, moduleNameString, mkModuleName)
|
||||
import HscTypes (HscEnv)
|
||||
import PackageConfig (PackageConfig)
|
||||
import GHC.Generics
|
||||
import Text.PrettyPrint (Doc)
|
||||
import Prelude
|
||||
|
||||
import Language.Haskell.GhcMod.Caching.Types
|
||||
|
||||
-- | A constraint alias (-XConstraintKinds) to make functions dealing with
|
||||
-- 'GhcModT' somewhat cleaner.
|
||||
@ -16,6 +49,18 @@ import PackageConfig (PackageConfig)
|
||||
-- the exported API so users have the option to use a custom inner monad.
|
||||
type IOish m = (Functor m, MonadIO m, MonadBaseControl IO m, ExceptionMonad m)
|
||||
|
||||
|
||||
-- MonadUtils of GHC 7.6 or earlier defines its own MonadIO.
|
||||
-- MonadUtils of GHC 7.8 or later imports MonadIO in Monad.Control.IO.Class.
|
||||
#if __GLASGOW_HASKELL__ < 708
|
||||
type MonadIOC m = (GHC.MonadIO m, MTL.MonadIO m)
|
||||
#else
|
||||
type MonadIOC m = (MTL.MonadIO m)
|
||||
#endif
|
||||
|
||||
class MonadIOC m => MonadIO m where
|
||||
liftIO :: IO a -> m a
|
||||
|
||||
-- | Output style.
|
||||
data OutputStyle = LispStyle -- ^ S expression style.
|
||||
| PlainStyle -- ^ Plain textstyle.
|
||||
@ -28,8 +73,15 @@ data Options = Options {
|
||||
outputStyle :: OutputStyle
|
||||
-- | Line separator string.
|
||||
, lineSeparator :: LineSeparator
|
||||
-- | Stdout/err line multiplexing using prefix encoding. @fst@ is stdout,
|
||||
-- @snd@ is stderr prefix.
|
||||
, linePrefix :: Maybe (String, String)
|
||||
-- | Verbosity
|
||||
, logLevel :: GmLogLevel
|
||||
-- | @ghc@ program name.
|
||||
, ghcProgram :: FilePath
|
||||
-- | @ghc-pkg@ program name.
|
||||
, ghcPkgProgram :: FilePath
|
||||
-- | @cabal@ program name.
|
||||
, cabalProgram :: FilePath
|
||||
-- | GHC command line options set on the @ghc-mod@ command line
|
||||
@ -43,41 +95,111 @@ data Options = Options {
|
||||
, hlintOpts :: [String]
|
||||
} deriving (Show)
|
||||
|
||||
|
||||
-- | A default 'Options'.
|
||||
defaultOptions :: Options
|
||||
defaultOptions = Options {
|
||||
outputStyle = PlainStyle
|
||||
, hlintOpts = []
|
||||
, lineSeparator = LineSeparator "\0"
|
||||
, linePrefix = Nothing
|
||||
, logLevel = GmWarning
|
||||
, ghcProgram = "ghc"
|
||||
, ghcPkgProgram = "ghc-pkg"
|
||||
, cabalProgram = "cabal"
|
||||
, ghcUserOptions = []
|
||||
, operators = False
|
||||
, detailed = False
|
||||
, qualified = False
|
||||
, lineSeparator = LineSeparator "\0"
|
||||
, hlintOpts = []
|
||||
}
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
data ProjectType = CabalProject | SandboxProject | PlainProject
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | The environment where this library is used.
|
||||
data Cradle = Cradle {
|
||||
cradleProjectType:: ProjectType
|
||||
-- | The directory where this library is executed.
|
||||
cradleCurrentDir :: FilePath
|
||||
, cradleCurrentDir :: FilePath
|
||||
-- | The project root directory.
|
||||
, cradleRootDir :: FilePath
|
||||
-- | Per-Project temporary directory
|
||||
, cradleTempDir :: FilePath
|
||||
-- | The file name of the found cabal file.
|
||||
, cradleCabalFile :: Maybe FilePath
|
||||
-- | Package database stack
|
||||
, cradlePkgDbStack :: [GhcPkgDb]
|
||||
} deriving (Eq, Show)
|
||||
|
||||
|
||||
data GmStream = GmOut | GmErr
|
||||
deriving (Show)
|
||||
|
||||
data GmLineType = GmTerminated | GmPartial
|
||||
deriving (Show)
|
||||
|
||||
data GmLines a = GmLines GmLineType a
|
||||
deriving (Show, Functor)
|
||||
|
||||
unGmLine :: GmLines a -> a
|
||||
unGmLine (GmLines _ s) = s
|
||||
|
||||
data GmOutput = GmOutputStdio
|
||||
| GmOutputChan (Chan (GmStream, GmLines String))
|
||||
|
||||
data GhcModEnv = GhcModEnv {
|
||||
gmOptions :: Options
|
||||
, gmCradle :: Cradle
|
||||
, gmOutput :: GmOutput
|
||||
}
|
||||
|
||||
data GhcModLog = GhcModLog {
|
||||
gmLogLevel :: Maybe GmLogLevel,
|
||||
gmLogVomitDump :: Last Bool,
|
||||
gmLogMessages :: [(GmLogLevel, String, Doc)]
|
||||
} deriving (Show)
|
||||
|
||||
instance Monoid GhcModLog where
|
||||
mempty = GhcModLog (Just GmPanic) (Last Nothing) mempty
|
||||
GhcModLog ml vd ls `mappend` GhcModLog ml' vd' ls' =
|
||||
GhcModLog (ml' `mplus` ml) (vd `mappend` vd') (ls `mappend` ls')
|
||||
|
||||
data GmGhcSession = GmGhcSession {
|
||||
gmgsOptions :: ![GHCOption],
|
||||
gmgsSession :: !(IORef HscEnv)
|
||||
}
|
||||
|
||||
data GhcModCaches = GhcModCaches {
|
||||
gmcPackageDbStack :: CacheContents ChCacheData [GhcPkgDb]
|
||||
, gmcMergedPkgOptions :: CacheContents ChCacheData [GHCOption]
|
||||
, gmcComponents :: CacheContents ChCacheData [GmComponent 'GMCRaw ChEntrypoint]
|
||||
, gmcResolvedComponents :: CacheContents
|
||||
[GmComponent 'GMCRaw (Set.Set ModulePath)]
|
||||
(Map.Map ChComponentName (GmComponent 'GMCResolved (Set.Set ModulePath)))
|
||||
}
|
||||
|
||||
data GhcModState = GhcModState {
|
||||
gmGhcSession :: !(Maybe GmGhcSession)
|
||||
, gmComponents :: !(Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath)))
|
||||
, gmCompilerMode :: !CompilerMode
|
||||
, gmCaches :: !GhcModCaches
|
||||
}
|
||||
|
||||
data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read)
|
||||
|
||||
defaultGhcModState :: GhcModState
|
||||
defaultGhcModState =
|
||||
GhcModState n Map.empty Simple (GhcModCaches n n n n)
|
||||
where n = Nothing
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- | GHC package database flags.
|
||||
data GhcPkgDb = GlobalDb | UserDb | PackageDb String deriving (Eq, Show)
|
||||
data GhcPkgDb = GlobalDb
|
||||
| UserDb
|
||||
| PackageDb String
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
instance Serialize GhcPkgDb
|
||||
|
||||
-- | A single GHC command line option.
|
||||
type GHCOption = String
|
||||
@ -112,21 +234,152 @@ showPkg (n,v,_) = intercalate "-" [n,v]
|
||||
showPkgId :: Package -> String
|
||||
showPkgId (n, v, i) = intercalate "-" [n, v, i]
|
||||
|
||||
-- | Collection of packages
|
||||
type PkgDb = (M.Map Package PackageConfig)
|
||||
|
||||
-- | Haskell expression.
|
||||
type Expression = String
|
||||
newtype Expression = Expression { getExpression :: String }
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
-- | Module name.
|
||||
type ModuleString = String
|
||||
newtype ModuleString = ModuleString { getModuleString :: String }
|
||||
deriving (Show, Read, Eq, Ord)
|
||||
|
||||
-- | A Module
|
||||
type Module = [String]
|
||||
data GmLogLevel =
|
||||
GmSilent
|
||||
| GmPanic
|
||||
| GmException
|
||||
| GmError
|
||||
| GmWarning
|
||||
| GmInfo
|
||||
| GmDebug
|
||||
| GmVomit
|
||||
deriving (Eq, Ord, Enum, Bounded, Show, Read)
|
||||
|
||||
-- | Option information for GHC
|
||||
data CompilerOptions = CompilerOptions {
|
||||
ghcOptions :: [GHCOption] -- ^ Command line options
|
||||
, includeDirs :: [IncludeDir] -- ^ Include directories for modules
|
||||
, depPackages :: [Package] -- ^ Dependent package names
|
||||
} deriving (Eq, Show)
|
||||
-- | Collection of packages
|
||||
type PkgDb = (Map Package PackageConfig)
|
||||
|
||||
data GmModuleGraph = GmModuleGraph {
|
||||
gmgGraph :: Map ModulePath (Set ModulePath)
|
||||
} deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
|
||||
instance Serialize GmModuleGraph where
|
||||
put GmModuleGraph {..} = put (mpim, graph)
|
||||
where
|
||||
mpim :: Map ModulePath Integer
|
||||
mpim = Map.fromList $ Map.keys gmgGraph `zip` [0..]
|
||||
graph :: Map Integer (Set Integer)
|
||||
graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph
|
||||
mpToInt :: ModulePath -> Integer
|
||||
mpToInt mp = fromJust $ Map.lookup mp mpim
|
||||
|
||||
get = do
|
||||
(mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get
|
||||
let impm = swapMap mpim
|
||||
intToMp i = fromJust $ Map.lookup i impm
|
||||
mpGraph :: Map ModulePath (Set ModulePath)
|
||||
mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph
|
||||
return $ GmModuleGraph mpGraph
|
||||
where
|
||||
swapMap :: (Ord k, Ord v) => Map k v -> Map v k
|
||||
swapMap = Map.fromList . map (\(x, y) -> (y, x)) . Map.toList
|
||||
|
||||
instance Monoid GmModuleGraph where
|
||||
mempty = GmModuleGraph mempty
|
||||
mappend (GmModuleGraph a) (GmModuleGraph a') =
|
||||
GmModuleGraph (Map.unionWith Set.union a a')
|
||||
|
||||
data GmComponentType = GMCRaw
|
||||
| GMCResolved
|
||||
data GmComponent (t :: GmComponentType) eps = GmComponent {
|
||||
gmcHomeModuleGraph :: GmModuleGraph
|
||||
, gmcName :: ChComponentName
|
||||
, gmcGhcOpts :: [GHCOption]
|
||||
, gmcGhcPkgOpts :: [GHCOption]
|
||||
, gmcGhcSrcOpts :: [GHCOption]
|
||||
, gmcGhcLangOpts :: [GHCOption]
|
||||
, gmcRawEntrypoints :: ChEntrypoint
|
||||
, gmcEntrypoints :: eps
|
||||
, gmcSourceDirs :: [FilePath]
|
||||
} deriving (Eq, Ord, Show, Read, Generic, Functor)
|
||||
|
||||
instance Serialize eps => Serialize (GmComponent t eps)
|
||||
|
||||
data ModulePath = ModulePath { mpModule :: ModuleName, mpPath :: FilePath }
|
||||
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
||||
instance Serialize ModulePath
|
||||
|
||||
instance Serialize ModuleName where
|
||||
get = mkModuleName <$> get
|
||||
put mn = put (moduleNameString mn)
|
||||
|
||||
instance Show ModuleName where
|
||||
show mn = "ModuleName " ++ show (moduleNameString mn)
|
||||
|
||||
instance Read ModuleName where
|
||||
readsPrec d =
|
||||
readParen
|
||||
(d > app_prec)
|
||||
(\r' -> [ (mkModuleName m, t)
|
||||
| ("ModuleName", s) <- lex r'
|
||||
, (m, t) <- readsPrec (app_prec + 1) s
|
||||
])
|
||||
where
|
||||
app_prec = 10
|
||||
|
||||
data GhcModError
|
||||
= GMENoMsg
|
||||
-- ^ Unknown error
|
||||
|
||||
| GMEString String
|
||||
-- ^ Some Error with a message. These are produced mostly by
|
||||
-- 'fail' calls on GhcModT.
|
||||
|
||||
| GMECabalConfigure GhcModError
|
||||
-- ^ Configuring a cabal project failed.
|
||||
|
||||
| GMECabalFlags GhcModError
|
||||
-- ^ Retrieval of the cabal configuration flags failed.
|
||||
|
||||
| GMECabalComponent ChComponentName
|
||||
-- ^ Cabal component could not be found
|
||||
|
||||
| GMECabalCompAssignment [(Either FilePath ModuleName, Set ChComponentName)]
|
||||
-- ^ Could not find a consistent component assignment for modules
|
||||
|
||||
| GMEProcess String [String] (Either (String, String, Int) GhcModError)
|
||||
-- ^ Launching an operating system process failed. Fields in
|
||||
-- order: command, arguments, (stdout, stderr, exitcode)
|
||||
|
||||
| GMENoCabalFile
|
||||
-- ^ No cabal file found.
|
||||
|
||||
| GMETooManyCabalFiles [FilePath]
|
||||
-- ^ Too many cabal files found.
|
||||
|
||||
| GMECabalStateFile GMConfigStateFileError
|
||||
-- ^ Reading Cabal's state configuration file falied somehow.
|
||||
deriving (Eq,Show,Typeable)
|
||||
|
||||
instance Error GhcModError where
|
||||
noMsg = GMENoMsg
|
||||
strMsg = GMEString
|
||||
|
||||
instance Exception GhcModError
|
||||
|
||||
data GMConfigStateFileError
|
||||
= GMConfigStateFileNoHeader
|
||||
| GMConfigStateFileBadHeader
|
||||
| GMConfigStateFileNoParse
|
||||
| GMConfigStateFileMissing
|
||||
-- | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo)
|
||||
deriving (Eq, Show, Read, Typeable)
|
||||
|
||||
|
||||
deriving instance Generic Version
|
||||
instance Serialize Version
|
||||
|
||||
instance Serialize Programs
|
||||
instance Serialize ChModuleName
|
||||
instance Serialize ChComponentName
|
||||
instance Serialize ChEntrypoint
|
||||
|
||||
mkLabel ''GhcModCaches
|
||||
mkLabel ''GhcModState
|
||||
|
@ -1,67 +1,67 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Language.Haskell.GhcMod.Utils where
|
||||
-- ghc-mod: Making Haskell development *more* fun
|
||||
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
|
||||
--
|
||||
-- This program is free software: you can redistribute it and/or modify
|
||||
-- it under the terms of the GNU Affero General Public License as published by
|
||||
-- the Free Software Foundation, either version 3 of the License, or
|
||||
-- (at your option) any later version.
|
||||
--
|
||||
-- This program is distributed in the hope that it will be useful,
|
||||
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
-- GNU Affero General Public License for more details.
|
||||
--
|
||||
-- You should have received a copy of the GNU Affero General Public License
|
||||
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
import Control.Arrow
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DoAndIfThenElse #-}
|
||||
|
||||
module Language.Haskell.GhcMod.Utils (
|
||||
module Language.Haskell.GhcMod.Utils
|
||||
, module Utils
|
||||
, readProcess
|
||||
) where
|
||||
|
||||
import Control.Applicative
|
||||
import Data.Char
|
||||
import Exception
|
||||
import Language.Haskell.GhcMod.Error
|
||||
import MonadUtils (MonadIO, liftIO)
|
||||
import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist)
|
||||
import System.Exit (ExitCode(..))
|
||||
import System.Process (readProcessWithExitCode)
|
||||
import System.Directory (getTemporaryDirectory)
|
||||
import System.FilePath (splitDrive, pathSeparators)
|
||||
import System.IO.Temp (createTempDirectory)
|
||||
#ifndef SPEC
|
||||
import Control.Applicative ((<$>))
|
||||
import Language.Haskell.GhcMod.Monad.Types
|
||||
import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist,
|
||||
getTemporaryDirectory, canonicalizePath)
|
||||
import System.Environment
|
||||
import System.FilePath ((</>),takeDirectory)
|
||||
#endif
|
||||
import System.FilePath (splitDrive, takeDirectory, takeFileName, pathSeparators,
|
||||
(</>))
|
||||
import System.IO.Temp (createTempDirectory)
|
||||
import System.Process (readProcess)
|
||||
import Text.Printf
|
||||
|
||||
import Paths_ghc_mod (getLibexecDir)
|
||||
import Utils
|
||||
import Prelude
|
||||
|
||||
-- dropWhileEnd is not provided prior to base 4.5.0.0.
|
||||
dropWhileEnd :: (a -> Bool) -> [a] -> [a]
|
||||
dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) []
|
||||
|
||||
extractParens :: String -> String
|
||||
extractParens str = extractParens' str 0
|
||||
where
|
||||
extractParens' :: String -> Int -> String
|
||||
extractParens' [] _ = []
|
||||
extractParens' (s:ss) level
|
||||
| s `elem` "([{" = s : extractParens' ss (level+1)
|
||||
| level == 0 = extractParens' ss 0
|
||||
| s `elem` "}])" && level == 1 = [s]
|
||||
| s `elem` "}])" = s : extractParens' ss (level-1)
|
||||
| otherwise = s : extractParens' ss level
|
||||
|
||||
readProcess' :: (MonadIO m, MonadError GhcModError m)
|
||||
=> String
|
||||
-> [String]
|
||||
-> m String
|
||||
readProcess' cmd opts = do
|
||||
(rv,output,err) <- liftIO (readProcessWithExitCode cmd opts "")
|
||||
`modifyError'` GMEProcess ([cmd] ++ opts)
|
||||
case rv of
|
||||
ExitFailure val -> do
|
||||
throwError $ GMEProcess ([cmd] ++ opts) $ strMsg $
|
||||
cmd ++ " " ++ unwords opts ++ " (exit " ++ show val ++ ")"
|
||||
++ "\n" ++ err
|
||||
ExitSuccess ->
|
||||
return output
|
||||
|
||||
withDirectory_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a
|
||||
withDirectory_ dir action =
|
||||
gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory)
|
||||
gbracket
|
||||
(liftIO getCurrentDirectory)
|
||||
(liftIO . setCurrentDirectory)
|
||||
(\_ -> liftIO (setCurrentDirectory dir) >> action)
|
||||
|
||||
uniqTempDirName :: FilePath -> FilePath
|
||||
uniqTempDirName dir = ("ghc-mod"++) $ uncurry (++)
|
||||
$ map escapeDriveChar *** map escapePathChar
|
||||
$ splitDrive dir
|
||||
uniqTempDirName dir =
|
||||
"ghc-mod" ++ map escapeDriveChar drive ++ map escapePathChar path
|
||||
where
|
||||
(drive, path) = splitDrive dir
|
||||
escapeDriveChar :: Char -> Char
|
||||
escapeDriveChar c
|
||||
| isAlphaNum c = c
|
||||
| otherwise = '-'
|
||||
|
||||
escapePathChar :: Char -> Char
|
||||
escapePathChar c
|
||||
| c `elem` pathSeparators = '-'
|
||||
| otherwise = c
|
||||
@ -70,25 +70,90 @@ newTempDir :: FilePath -> IO FilePath
|
||||
newTempDir dir =
|
||||
flip createTempDirectory (uniqTempDirName dir) =<< getTemporaryDirectory
|
||||
|
||||
mightExist :: FilePath -> IO (Maybe FilePath)
|
||||
mightExist f = do
|
||||
exists <- doesFileExist f
|
||||
return $ if exists then (Just f) else (Nothing)
|
||||
whenM :: Monad m => m Bool -> m () -> m ()
|
||||
whenM mb ma = mb >>= flip when ma
|
||||
|
||||
-- | Returns the path to the currently running ghc-mod executable. With ghc<7.6
|
||||
-- this is a guess but >=7.6 uses 'getExecutablePath'.
|
||||
ghcModExecutable :: IO FilePath
|
||||
#ifndef SPEC
|
||||
ghcModExecutable = do
|
||||
dir <- getExecutablePath'
|
||||
return $ dir </> "ghc-mod"
|
||||
where
|
||||
dir <- takeDirectory <$> getExecutablePath'
|
||||
return $ (if dir == "." then "" else dir) </> "ghc-mod"
|
||||
#else
|
||||
ghcModExecutable = fmap (</> "dist/build/ghc-mod/ghc-mod") getCurrentDirectory
|
||||
#endif
|
||||
|
||||
findLibexecExe :: String -> IO FilePath
|
||||
findLibexecExe "cabal-helper-wrapper" = do
|
||||
libexecdir <- getLibexecDir
|
||||
let exeName = "cabal-helper-wrapper"
|
||||
exe = libexecdir </> exeName
|
||||
|
||||
exists <- doesFileExist exe
|
||||
|
||||
if exists
|
||||
then return exe
|
||||
else do
|
||||
mdir <- tryFindGhcModTreeDataDir
|
||||
case mdir of
|
||||
Nothing ->
|
||||
error $ libexecNotExitsError exeName libexecdir
|
||||
Just dir ->
|
||||
return $ dir </> "dist" </> "build" </> exeName </> exeName
|
||||
findLibexecExe exe = error $ "findLibexecExe: Unknown executable: " ++ exe
|
||||
|
||||
libexecNotExitsError :: String -> FilePath -> String
|
||||
libexecNotExitsError exe dir = printf
|
||||
( "Could not find $libexecdir/%s\n"
|
||||
++"\n"
|
||||
++"If you are a developer set the environment variable `ghc_mod_libexecdir'\n"
|
||||
++"to override $libexecdir[1] the following will work in the ghc-mod tree:\n"
|
||||
++"\n"
|
||||
++" $ export ghc_mod_libexecdir=$PWD/dist/build/%s\n"
|
||||
++"\n"
|
||||
++"[1]: %s\n"
|
||||
++"\n"
|
||||
++"If you don't know what I'm talking about something went wrong with your\n"
|
||||
++"installation. Please report this problem here:\n"
|
||||
++"\n"
|
||||
++" https://github.com/kazu-yamamoto/ghc-mod/issues") exe exe dir
|
||||
|
||||
tryFindGhcModTreeLibexecDir :: IO (Maybe FilePath)
|
||||
tryFindGhcModTreeLibexecDir = do
|
||||
exe <- getExecutablePath'
|
||||
dir <- case takeFileName exe of
|
||||
"ghc" -> getCurrentDirectory -- we're probably in ghci; try CWD
|
||||
_ -> return $ (!!4) $ iterate takeDirectory exe
|
||||
exists <- doesFileExist $ dir </> "ghc-mod.cabal"
|
||||
return $ if exists
|
||||
then Just dir
|
||||
else Nothing
|
||||
|
||||
tryFindGhcModTreeDataDir :: IO (Maybe FilePath)
|
||||
tryFindGhcModTreeDataDir = do
|
||||
dir <- (!!4) . iterate takeDirectory <$> getExecutablePath'
|
||||
exists <- doesFileExist $ dir </> "ghc-mod.cabal"
|
||||
return $ if exists
|
||||
then Just dir
|
||||
else Nothing
|
||||
|
||||
readLibExecProcess' :: (MonadIO m, ExceptionMonad m)
|
||||
=> String -> [String] -> m String
|
||||
readLibExecProcess' cmd args = do
|
||||
exe <- liftIO $ findLibexecExe cmd
|
||||
liftIO $ readProcess exe args ""
|
||||
|
||||
getExecutablePath' :: IO FilePath
|
||||
#if __GLASGOW_HASKELL__ >= 706
|
||||
getExecutablePath' = takeDirectory <$> getExecutablePath
|
||||
getExecutablePath' = getExecutablePath
|
||||
#else
|
||||
getExecutablePath' = return ""
|
||||
# endif
|
||||
#else
|
||||
ghcModExecutable = return "dist/build/ghc-mod/ghc-mod"
|
||||
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
|
||||
|
@ -1,89 +1,52 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Language.Haskell.GhcMod.World where
|
||||
{-(
|
||||
, World
|
||||
, getCurrentWorld
|
||||
, isWorldChanged
|
||||
) where
|
||||
-}
|
||||
|
||||
import Language.Haskell.GhcMod.GhcPkg
|
||||
import Language.Haskell.GhcMod.PathsAndFiles
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.Monad.Types
|
||||
import Language.Haskell.GhcMod.Utils
|
||||
|
||||
import Control.Applicative (pure,(<$>),(<*>))
|
||||
import Control.Applicative
|
||||
import Data.Maybe
|
||||
import Data.Traversable (traverse)
|
||||
import System.Directory (getModificationTime)
|
||||
import Data.Traversable hiding (mapM)
|
||||
import System.FilePath ((</>))
|
||||
|
||||
import GHC.Paths (libdir)
|
||||
|
||||
#if __GLASGOW_HASKELL__ <= 704
|
||||
import System.Time (ClockTime)
|
||||
#else
|
||||
import Data.Time (UTCTime)
|
||||
#endif
|
||||
|
||||
|
||||
#if __GLASGOW_HASKELL__ <= 704
|
||||
type ModTime = ClockTime
|
||||
#else
|
||||
type ModTime = UTCTime
|
||||
#endif
|
||||
|
||||
data TimedFile = TimedFile FilePath ModTime deriving (Eq, Show)
|
||||
|
||||
instance Ord TimedFile where
|
||||
compare (TimedFile _ a) (TimedFile _ b) = compare a b
|
||||
|
||||
timeFile :: FilePath -> IO TimedFile
|
||||
timeFile f = TimedFile <$> pure f <*> getModificationTime f
|
||||
import Prelude
|
||||
|
||||
data World = World {
|
||||
worldPackageCaches :: [TimedFile]
|
||||
, worldCabalFile :: Maybe TimedFile
|
||||
, worldCabalConfig :: Maybe TimedFile
|
||||
, worldSymbolCache :: Maybe TimedFile
|
||||
} deriving (Eq, Show)
|
||||
|
||||
timedPackageCache :: Cradle -> IO [TimedFile]
|
||||
timedPackageCache crdl = do
|
||||
fs <- mapM mightExist . map (</> packageCache)
|
||||
=<< getPackageCachePaths libdir crdl
|
||||
timeFile `mapM` catMaybes fs
|
||||
timedPackageCaches :: IOish m => GhcModT m [TimedFile]
|
||||
timedPackageCaches = do
|
||||
fs <- mapM (liftIO . mightExist) . map (</> packageCache)
|
||||
=<< getPackageCachePaths libdir
|
||||
(liftIO . timeFile) `mapM` catMaybes fs
|
||||
|
||||
getCurrentWorld :: Cradle -> IO World
|
||||
getCurrentWorld crdl = do
|
||||
pkgCaches <- timedPackageCache crdl
|
||||
mCabalFile <- timeFile `traverse` cradleCabalFile crdl
|
||||
mSetupConfig <- mightExist (setupConfigFile crdl)
|
||||
mCabalConfig <- timeFile `traverse` mSetupConfig
|
||||
getCurrentWorld :: IOish m => GhcModT m World
|
||||
getCurrentWorld = do
|
||||
crdl <- cradle
|
||||
pkgCaches <- timedPackageCaches
|
||||
mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl
|
||||
mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl)
|
||||
mSymbolCache <- liftIO $ timeMaybe (symbolCache crdl)
|
||||
|
||||
return World {
|
||||
worldPackageCaches = pkgCaches
|
||||
, worldCabalFile = mCabalFile
|
||||
, worldCabalConfig = mCabalConfig
|
||||
, worldSymbolCache = mSymbolCache
|
||||
}
|
||||
|
||||
didWorldChange :: World -> Cradle -> IO Bool
|
||||
didWorldChange world crdl = do
|
||||
(world /=) <$> getCurrentWorld crdl
|
||||
didWorldChange :: IOish m => World -> GhcModT m Bool
|
||||
didWorldChange world = do
|
||||
(world /=) <$> getCurrentWorld
|
||||
|
||||
-- * Neither file exists -> should return False:
|
||||
-- @Nothing < Nothing = False@
|
||||
-- (since we don't need to @cabal configure@ when no cabal file exists.)
|
||||
--
|
||||
-- * Cabal file doesn't exist (unlikely case) -> should return False
|
||||
-- @Just cc < Nothing = False@
|
||||
-- TODO: should we delete dist/setup-config?
|
||||
--
|
||||
-- * dist/setup-config doesn't exist yet -> should return True:
|
||||
-- @Nothing < Just cf = True@
|
||||
--
|
||||
-- * Both files exist
|
||||
-- @Just cc < Just cf = cc < cf = cc `olderThan` cf@
|
||||
isSetupConfigOutOfDate :: Cradle -> IO Bool
|
||||
isSetupConfigOutOfDate crdl = do
|
||||
world <- getCurrentWorld crdl
|
||||
return $ worldCabalConfig world < worldCabalFile world
|
||||
isYoungerThanSetupConfig :: FilePath -> World -> IO Bool
|
||||
isYoungerThanSetupConfig file World {..} = do
|
||||
tfile <- timeFile file
|
||||
return $ worldCabalConfig < Just tfile
|
||||
|
@ -1,9 +1,9 @@
|
||||
-- Copyright : Isaac Jones 2003-2004
|
||||
{- All rights reserved.
|
||||
Copyright Ben Millwood 2012
|
||||
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
modification, are permitted provided that the following conditions are
|
||||
met:
|
||||
modification, are permitted provided that the following conditions are met:
|
||||
|
||||
* Redistributions of source code must retain the above copyright
|
||||
notice, this list of conditions and the following disclaimer.
|
||||
@ -13,7 +13,7 @@ met:
|
||||
disclaimer in the documentation and/or other materials provided
|
||||
with the distribution.
|
||||
|
||||
* Neither the name of Isaac Jones nor the names of other
|
||||
* Neither the name of Ben Millwood nor the names of other
|
||||
contributors may be used to endorse or promote products derived
|
||||
from this software without specific prior written permission.
|
||||
|
||||
@ -27,19 +27,4 @@ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
|
||||
|
||||
|
||||
-- | ComponentLocalBuildInfo for Cabal <= 1.16
|
||||
module Language.Haskell.GhcMod.Cabal16 (
|
||||
ComponentLocalBuildInfo
|
||||
, componentPackageDeps
|
||||
) where
|
||||
|
||||
import Distribution.Package (InstalledPackageId, PackageIdentifier)
|
||||
|
||||
-- From Cabal <= 1.16
|
||||
data ComponentLocalBuildInfo = ComponentLocalBuildInfo {
|
||||
componentPackageDeps :: [(InstalledPackageId, PackageIdentifier)]
|
||||
}
|
||||
deriving (Read, Show)
|
||||
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
164
NotCPP/Declarations.hs
Normal file
164
NotCPP/Declarations.hs
Normal 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
38
NotCPP/LookupValueName.hs
Normal 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
114
NotCPP/OrphanEvasion.hs
Normal 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
65
NotCPP/ScopeLookup.hs
Normal 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
29
NotCPP/Utils.hs
Normal 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
22
README.md
@ -44,7 +44,27 @@ Make sure you're not using the MELPA version of `ghc.el` otherwise you might get
|
||||
all sorts of nasty conflicts.
|
||||
|
||||
|
||||
## Custom ghc-mod cradle
|
||||
|
||||
To customize the package databases used by `ghc-mod`, put a file called `ghc-mod.cradle` beside the `.cabal` file with the following syntax:
|
||||
|
||||
```
|
||||
temp directory root
|
||||
package db 1
|
||||
...
|
||||
package db n
|
||||
```
|
||||
|
||||
each package database line is either a *path* to a package database, or `global` or `user`.
|
||||
|
||||
## IRC
|
||||
|
||||
If you have any problems, suggestions, comments swing by
|
||||
[#ghc-mod](irc://chat.freenode.net/ghc-mod) on Freenode.
|
||||
[\#ghc-mod (web client)](https://kiwiirc.com/client/irc.freenode.org/ghc-mod) on
|
||||
Freenode. If you're reporting a bug please also create an issue
|
||||
[here](https://github.com/kazu-yamamoto/ghc-mod/issues) so we have a way to contact
|
||||
you if you don't have time to stay.
|
||||
|
||||
Do hang around for a while if no one answers and repeat your question if you
|
||||
still haven't gotten any answer after a day or so. You're most likely to get an
|
||||
answer during the day in GMT+1.
|
||||
|
198
Setup.hs
Normal file → Executable file
198
Setup.hs
Normal file → Executable file
@ -1,2 +1,198 @@
|
||||
#!/usr/bin/env runhaskell
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
import Distribution.Simple
|
||||
main = defaultMain
|
||||
import Distribution.Simple.Setup
|
||||
import Distribution.Simple.Install
|
||||
import Distribution.Simple.Register
|
||||
import Distribution.Simple.InstallDirs as ID
|
||||
import Distribution.Simple.LocalBuildInfo
|
||||
import Distribution.PackageDescription
|
||||
|
||||
import Control.Arrow
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.Version
|
||||
import Data.Monoid
|
||||
import System.Process
|
||||
import System.Exit
|
||||
import System.FilePath
|
||||
import Text.ParserCombinators.ReadP
|
||||
|
||||
import SetupCompat
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMainWithHooks $ simpleUserHooks {
|
||||
confHook = \(gpd, hbi) cf ->
|
||||
xBuildDependsLike <$> (confHook simpleUserHooks) (gpd, hbi) cf
|
||||
|
||||
, instHook = inst
|
||||
, copyHook = copy
|
||||
|
||||
-- , postConf = sanityCheckCabalVersions
|
||||
}
|
||||
|
||||
xBuildDependsLike :: LocalBuildInfo -> LocalBuildInfo
|
||||
xBuildDependsLike lbi =
|
||||
let
|
||||
cc = componentsConfigs lbi
|
||||
pd = localPkgDescr lbi
|
||||
deps = dependsMap lbi
|
||||
in setComponentsConfigs lbi
|
||||
[ (cn, updateClbi deps comp clbi, cdeps)
|
||||
| (cn, clbi, cdeps) <- cc
|
||||
, let comp = getComponent pd cn
|
||||
]
|
||||
|
||||
where
|
||||
updateClbi deps comp clbi = setUnionDeps (otherDeps deps comp) clbi
|
||||
|
||||
dependsMap ::
|
||||
LocalBuildInfo -> [(ComponentName, Deps)]
|
||||
dependsMap lbi =
|
||||
second getDeps <$> allComponentsInBuildOrder lbi
|
||||
|
||||
otherDeps :: [(ComponentName, Deps)] -> Component -> Deps
|
||||
otherDeps deps comp = fromMaybe noDeps $
|
||||
flip lookup deps =<< read <$> lookup "x-build-depends-like" fields
|
||||
where
|
||||
fields = customFieldsBI (componentBuildInfo comp)
|
||||
|
||||
-- mostly copypasta from 'defaultInstallHook'
|
||||
inst ::
|
||||
PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO ()
|
||||
inst pd lbi _uf ifl = do
|
||||
let copyFlags = defaultCopyFlags {
|
||||
copyDistPref = installDistPref ifl,
|
||||
copyDest = toFlag NoCopyDest,
|
||||
copyVerbosity = installVerbosity ifl
|
||||
}
|
||||
xInstallTarget pd lbi (\pd' lbi' -> install pd' lbi' copyFlags)
|
||||
let registerFlags = defaultRegisterFlags {
|
||||
regDistPref = installDistPref ifl,
|
||||
regInPlace = installInPlace ifl,
|
||||
regPackageDB = installPackageDB ifl,
|
||||
regVerbosity = installVerbosity ifl
|
||||
}
|
||||
when (hasLibs pd) $ register pd lbi registerFlags
|
||||
|
||||
copy :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO ()
|
||||
copy pd lbi _uh cf =
|
||||
xInstallTarget pd lbi (\pd' lbi' -> install pd' lbi' cf)
|
||||
|
||||
xInstallTarget :: PackageDescription
|
||||
-> LocalBuildInfo
|
||||
-> (PackageDescription -> LocalBuildInfo -> IO ())
|
||||
-> IO ()
|
||||
xInstallTarget pd lbi fn = do
|
||||
let (extended, regular) = partition (isJust . installTarget) (executables pd)
|
||||
|
||||
let pd_regular = pd { executables = regular }
|
||||
|
||||
_ <- flip mapM extended $ \exe -> do
|
||||
putStrLn $ "extended " ++ show (exeName exe)
|
||||
|
||||
let
|
||||
idirtpl = installDirTemplates lbi
|
||||
env = installDirsTemplateEnv idirtpl
|
||||
libexecdir' = fromPathTemplate (libexecdir idirtpl)
|
||||
|
||||
pd_extended = onlyExePackageDesc [exe] pd
|
||||
install_target = fromJust $ installTarget exe
|
||||
install_target' = ID.substPathTemplate env install_target
|
||||
-- $libexec isn't a real thing :/ so we have to simulate it
|
||||
install_target'' = substLibExec' libexecdir' install_target'
|
||||
|
||||
let lbi' = lbi {
|
||||
installDirTemplates =
|
||||
(installDirTemplates lbi) {
|
||||
bindir = install_target''
|
||||
}
|
||||
}
|
||||
fn pd_extended lbi'
|
||||
|
||||
fn pd_regular lbi
|
||||
|
||||
where
|
||||
installTarget :: Executable -> Maybe PathTemplate
|
||||
installTarget exe =
|
||||
toPathTemplate <$> lookup "x-install-target" (customFieldsBI $ buildInfo exe)
|
||||
|
||||
substLibExec libexecdir "$libexecdir" = libexecdir
|
||||
substLibExec _ comp = comp
|
||||
|
||||
substLibExec' dir =
|
||||
withPT $
|
||||
withSP $ map (substLibExec dir . dropTrailingPathSeparator)
|
||||
|
||||
|
||||
withPT f pt = toPathTemplate $ f (fromPathTemplate pt)
|
||||
withSP f p = joinPath $ f (splitPath p)
|
||||
|
||||
onlyExePackageDesc :: [Executable] -> PackageDescription -> PackageDescription
|
||||
onlyExePackageDesc exes pd = emptyPackageDescription {
|
||||
package = package pd
|
||||
, executables = exes
|
||||
}
|
||||
|
||||
parseVer str =
|
||||
case filter ((=="") . snd) $ readP_to_S parseVersion str of
|
||||
[(ver, _)] -> ver
|
||||
_ -> error $ "No parse (Ver) :(\n" ++ str ++ "\n"
|
||||
|
||||
-- sanityCheckCabalVersions args cf desc lbi = do
|
||||
-- (cabalInstallVer, cabalVer) <- getCabalExecVer
|
||||
|
||||
-- let
|
||||
-- ghcVer = compilerVersion (compiler lbi)
|
||||
-- -- ghc >= 7.10?
|
||||
-- minGhc710 = ghcVer `withinRange` orLaterVersion (parseVer "7.10")
|
||||
|
||||
-- when minGhc710 $ do
|
||||
-- let cabalHelperCabalVer = compCabalVer (CExeName "cabal-helper")
|
||||
|
||||
-- when (not $ cabalVer `sameMajorVersionAs` cabalHelperCabalVer) $
|
||||
-- failCabalVersionDifferent cabalVer cabalHelperCabalVer
|
||||
|
||||
-- -- carry on as usual
|
||||
-- (postConf simpleUserHooks) args cf desc lbi
|
||||
|
||||
-- where
|
||||
-- earlierVersionThan ver ver' =
|
||||
-- ver `withinRange` earlierVersion ver'
|
||||
-- sameMajorVersionAs ver ver' =
|
||||
-- ver `withinRange` withinVersion (Version (take 2 $ versionBranch ver') [])
|
||||
|
||||
-- compCabalVer comp = let
|
||||
-- clbi = getComponentLocalBuildInfo lbi comp
|
||||
|
||||
-- [cabalVer] =
|
||||
-- [ ver | (_, PackageIdentifier pkg ver) <- componentPackageDeps clbi
|
||||
-- , pkg == PackageName "Cabal" ]
|
||||
-- in cabalVer
|
||||
|
||||
-- getCabalExecVer = do
|
||||
-- ["cabal-install", "version", cabalInstallVer, "using", "version", cabalVer, "of", "the", "Cabal", "library"] <- words <$> readProcess "cabal" ["--version"] ""
|
||||
-- return (parseVer cabalInstallVer, parseVer cabalVer)
|
||||
|
||||
-- failCabalVersionDifferent cabalVer libCabalVer =
|
||||
-- putStrLn rerr >> exitFailure
|
||||
-- where
|
||||
-- replace :: String -> String -> String -> String
|
||||
-- replace _ _ [] = []
|
||||
-- replace n r h@(h':hs)
|
||||
-- | map snd (n `zip` h ) == n = r ++ replace n r (drop (length n) h)
|
||||
-- | otherwise = h':replace n r hs
|
||||
|
||||
-- rerr = replace "X.XX.X.X" (showVersion libCabalVer) $
|
||||
-- replace "Y.YY.Y.Y" (showVersion cabalVer) err
|
||||
-- err = "\
|
||||
-- \Error: Cabal seems to have decided ghc-mod should be built using Cabal\n\
|
||||
-- \X.XX.X.X while the `cabal' executable in your PATH was built with Cabal\n\
|
||||
-- \Y.YY.Y.Y. This will lead to conflicts when running ghc-mod in any project\n\
|
||||
-- \where you use this `cabal' executable. Please compile ghc-mod using the same\n\
|
||||
-- \Cabal version as your `cabal' executable or recompile cabal-install using\n\
|
||||
-- \this version of the Cabal library.\n\
|
||||
-- \\n\
|
||||
-- \See: https://github.com/kazu-yamamoto/ghc-mod/wiki/InconsistentCabalVersions\n"
|
||||
|
198
SetupCompat.hs
Normal file
198
SetupCompat.hs
Normal 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
37
Utils.hs
Normal 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
|
@ -119,7 +119,7 @@ foo xs = foldr bar id xs
|
||||
bar = (:)
|
||||
|<
|
||||
|
||||
C-xC-s highlights the 2nd line. C-c? displays the following:
|
||||
C-xC-s highlights the 2nd line. M-? displays the following:
|
||||
|
||||
>|
|
||||
Couldn't match type `[a -> a]' with `a -> a'
|
||||
@ -139,7 +139,7 @@ foo xs = foldr _bar id xs
|
||||
bar = (:)
|
||||
|<
|
||||
|
||||
C-c? displays:
|
||||
M-? displays:
|
||||
|
||||
>|
|
||||
Found hole `_bar' with type: (a -> a) -> (a -> a) -> a -> a
|
||||
|
@ -20,7 +20,7 @@
|
||||
:underline (:style wave :color "orangered"))
|
||||
(t
|
||||
:inherit error))
|
||||
"Face used for marking error lines."
|
||||
"Face used for error lines."
|
||||
:group 'ghc)
|
||||
|
||||
(defface ghc-face-warn
|
||||
@ -28,7 +28,7 @@
|
||||
:underline (:style wave :color "gold"))
|
||||
(t
|
||||
:inherit warning))
|
||||
"Face used for marking warning lines."
|
||||
"Face used for warning lines."
|
||||
:group 'ghc)
|
||||
|
||||
(defface ghc-face-hole
|
||||
@ -36,7 +36,7 @@
|
||||
:underline (:style wave :color "purple"))
|
||||
(t
|
||||
:inherit warning))
|
||||
"Face used for marking hole lines."
|
||||
"Face used for hole lines."
|
||||
:group 'ghc)
|
||||
|
||||
(defvar ghc-check-error-fringe (propertize "!" 'display '(left-fringe exclamation-mark)))
|
||||
@ -46,27 +46,34 @@
|
||||
(defvar ghc-check-hole-fringe (propertize "_" 'display '(left-fringe horizontal-bar)))
|
||||
|
||||
(defvar ghc-display-error nil
|
||||
"*An action to display errors/warnings for 'M-n' and 'M-p:
|
||||
"*How to display errors/warnings when using 'M-n' and 'M-p':
|
||||
|
||||
nil does not display errors/warnings.
|
||||
'minibuffer displays errors/warnings in the minibuffer.
|
||||
'other-buffer displays errors/warnings in the other buffer.
|
||||
nil do not display errors/warnings.
|
||||
'minibuffer display errors/warnings in the minibuffer.
|
||||
'other-buffer display errors/warnings in a new buffer.
|
||||
")
|
||||
|
||||
(defvar ghc-display-hole 'other-buffer
|
||||
"*An action to display hole information for 'C-c C-j' and 'C-c C-h'
|
||||
"*How to display hole information when using 'C-c C-j' and 'C-c C-h'
|
||||
|
||||
'minibuffer displays errors/warnings in the minibuffer.
|
||||
'other-buffer displays errors/warnings in the other buffer"
|
||||
'minibuffer display errors/warnings in the minibuffer.
|
||||
'other-buffer display errors/warnings in the a new buffer"
|
||||
)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun ghc-check-syntax ()
|
||||
(interactive)
|
||||
;; Only check syntax of visible buffers
|
||||
(when (and (buffer-file-name)
|
||||
(file-exists-p (buffer-file-name))
|
||||
(get-buffer-window (current-buffer) t))
|
||||
(with-timeout
|
||||
(10 (error "ghc process may have hung or exited with an error"))
|
||||
(while ghc-process-running (sleep-for 0.1)))
|
||||
(ghc-with-process (ghc-check-send)
|
||||
'ghc-check-callback
|
||||
(lambda () (setq mode-line-process " -:-"))))
|
||||
(lambda () (setq mode-line-process " -:-")))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
@ -132,7 +139,7 @@ nil does not display errors/warnings.
|
||||
info infos)
|
||||
(dolist (err errs (nreverse infos))
|
||||
(when (string-match regex err)
|
||||
(let* ((file (expand-file-name (match-string 1 err))) ;; for Windows
|
||||
(let* ((file (expand-file-name (match-string 1 err) ghc-process-root)) ;; for Windows
|
||||
(line (string-to-number (match-string 2 err)))
|
||||
(coln (string-to-number (match-string 3 err)))
|
||||
(msg (match-string 4 err))
|
||||
@ -167,18 +174,20 @@ nil does not display errors/warnings.
|
||||
;; If this is a bottleneck for a large code, let's fix.
|
||||
(goto-char (point-min))
|
||||
(cond
|
||||
((and (string= ofile file) hole)
|
||||
((string= (file-truename ofile) (file-truename file))
|
||||
(if hole
|
||||
(progn
|
||||
(forward-line (1- line))
|
||||
(forward-char (1- coln))
|
||||
(setq beg (point))
|
||||
(forward-char (length hole))
|
||||
(setq end (point)))
|
||||
((string= ofile file)
|
||||
(progn
|
||||
(forward-line (1- line))
|
||||
(while (eq (char-after) 32) (forward-char))
|
||||
(forward-char (1- coln))
|
||||
(setq beg (point))
|
||||
(forward-line)
|
||||
(setq end (1- (point))))
|
||||
(skip-chars-forward "^[:space:]" (line-end-position))
|
||||
(setq end (point)))))
|
||||
(t
|
||||
(setq beg (point))
|
||||
(forward-line)
|
||||
|
@ -25,7 +25,7 @@
|
||||
(setq pkg-ver-path (and mod (ghc-resolve-document-path mod)))
|
||||
(if pkg-ver-path
|
||||
(ghc-display-document pkg-ver-path mod haskell-org expr)
|
||||
(message "No document found"))))
|
||||
(message "No documentation found"))))
|
||||
|
||||
(ghc-defstruct pkg-ver-path pkg ver path)
|
||||
|
||||
@ -93,7 +93,7 @@
|
||||
(read-from-minibuffer "Module name: " def ghc-input-map))
|
||||
|
||||
(defun ghc-read-expression (def)
|
||||
(read-from-minibuffer "Expression: " def ghc-input-map))
|
||||
(read-from-minibuffer "Identifier: " def ghc-input-map))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
@ -182,9 +182,19 @@
|
||||
(funcall ins-func)
|
||||
(goto-char (point-min))
|
||||
(if (not fontify)
|
||||
;; turn-off-haskell-font-lock has been removed from haskell-mode
|
||||
;; test if the function is defined in our version
|
||||
(if (fboundp 'turn-off-haskell-font-lock)
|
||||
(turn-off-haskell-font-lock)
|
||||
;; it's not defined, fallback on font-lock-mode
|
||||
(font-lock-mode -1))
|
||||
(haskell-font-lock-defaults-create)
|
||||
(turn-on-haskell-font-lock)))
|
||||
;; turn-on-haskell-font-lock has been removed from haskell-mode
|
||||
;; test if the function is defined in our version
|
||||
(if (fboundp 'turn-on-haskell-font-lock)
|
||||
(turn-on-haskell-font-lock)
|
||||
;; it's not defined, fallback on font-lock-mode
|
||||
(turn-on-font-lock))))
|
||||
(display-buffer buf
|
||||
'((display-buffer-reuse-window
|
||||
display-buffer-pop-up-window))))))
|
||||
|
@ -82,7 +82,7 @@
|
||||
(if (null tinfos)
|
||||
(progn
|
||||
(ghc-type-clear-overlay)
|
||||
(message "Cannot guess type"))
|
||||
(message "Cannot determine type"))
|
||||
(let* ((tinfo (nth (ghc-type-get-ix) tinfos))
|
||||
(type (ghc-tinfo-get-info tinfo))
|
||||
(beg-line (ghc-tinfo-get-beg-line tinfo))
|
||||
@ -127,7 +127,7 @@
|
||||
(defun ghc-expand-th ()
|
||||
(interactive)
|
||||
(let* ((file (buffer-file-name))
|
||||
(cmds (list "expand" file))
|
||||
(cmds (list "-b" "\n" "expand" file))
|
||||
(source (ghc-run-ghc-mod cmds)))
|
||||
(when source
|
||||
(ghc-display
|
||||
|
@ -2,4 +2,4 @@
|
||||
"ghc"
|
||||
2.0.0
|
||||
"Sub mode for Haskell mode"
|
||||
nil)
|
||||
'((haskell-mode "13.0")))
|
||||
|
@ -10,6 +10,9 @@
|
||||
|
||||
(require 'ghc-func)
|
||||
|
||||
(defvar ghc-debug-options nil)
|
||||
;; (setq ghc-debug-options '("-v9"))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defvar ghc-process-running nil)
|
||||
@ -19,8 +22,11 @@
|
||||
(defvar-local ghc-process-original-file nil)
|
||||
(defvar-local ghc-process-callback nil)
|
||||
(defvar-local ghc-process-hook nil)
|
||||
(defvar-local ghc-process-root nil)
|
||||
|
||||
(defvar ghc-interactive-command "ghc-modi")
|
||||
(defvar ghc-command "ghc-mod")
|
||||
|
||||
(defvar ghc-error-buffer "*GHC Error*")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
@ -28,14 +34,15 @@
|
||||
(ghc-run-ghc-mod '("root")))
|
||||
|
||||
(defun ghc-with-process (cmd callback &optional hook1 hook2)
|
||||
(let ((root (ghc-get-project-root)))
|
||||
(unless ghc-process-process-name
|
||||
(setq ghc-process-process-name (ghc-get-project-root)))
|
||||
(setq ghc-process-process-name root))
|
||||
(when (and ghc-process-process-name (not ghc-process-running))
|
||||
(setq ghc-process-running t)
|
||||
(if hook1 (funcall hook1))
|
||||
(let* ((cbuf (current-buffer))
|
||||
(name ghc-process-process-name)
|
||||
(buf (get-buffer-create (concat " ghc-modi:" name)))
|
||||
(buf (get-buffer-create (concat " ghc-mod:" name)))
|
||||
(file (buffer-file-name))
|
||||
(cpro (get-process name)))
|
||||
(ghc-with-current-buffer buf
|
||||
@ -43,13 +50,14 @@
|
||||
(setq ghc-process-original-file file)
|
||||
(setq ghc-process-callback callback)
|
||||
(setq ghc-process-hook hook2)
|
||||
(setq ghc-process-root root)
|
||||
(erase-buffer)
|
||||
(let ((pro (ghc-get-process cpro name buf)))
|
||||
(process-send-string pro cmd)
|
||||
(when ghc-debug
|
||||
(ghc-with-debug-buffer
|
||||
(insert (format "%% %s" cmd))))
|
||||
pro)))))
|
||||
pro))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
@ -63,37 +71,74 @@
|
||||
(t cpro)))
|
||||
|
||||
(defun ghc-start-process (name buf)
|
||||
(let* ((opts (append '("-b" "\n" "-l") (ghc-make-ghc-options)))
|
||||
(pro (apply 'start-file-process name buf ghc-interactive-command opts)))
|
||||
(let* ((opts (append ghc-debug-options
|
||||
'("-b" "\n" "-l" "--line-prefix=O: ,E: ")
|
||||
(ghc-make-ghc-options)
|
||||
'("legacy-interactive")))
|
||||
(pro (apply 'start-file-process name buf ghc-command opts)))
|
||||
(set-process-filter pro 'ghc-process-filter)
|
||||
(set-process-sentinel pro 'ghc-process-sentinel)
|
||||
(set-process-query-on-exit-flag pro nil)
|
||||
pro))
|
||||
|
||||
(defun ghc-process-filter (process string)
|
||||
(let ((pbuf (process-buffer process)))
|
||||
(let* ((pbuf (process-buffer process))
|
||||
(tbufname (concat " tmp " (buffer-name pbuf)))
|
||||
tbuf)
|
||||
(if (not (get-buffer pbuf))
|
||||
(setq ghc-process-running nil) ;; just in case
|
||||
(ghc-with-current-buffer (process-buffer process)
|
||||
(ghc-with-current-buffer pbuf
|
||||
(when ghc-debug
|
||||
(ghc-with-debug-buffer
|
||||
(insert string)))
|
||||
(with-current-buffer (get-buffer-create tbufname)
|
||||
(setq tbuf (current-buffer))
|
||||
(goto-char (point-max))
|
||||
(insert string)
|
||||
(goto-char (point-min))
|
||||
(let ((cont t) end out)
|
||||
(while (and cont (not (eobp)))
|
||||
(cond
|
||||
((looking-at "^O: ")
|
||||
(setq out t))
|
||||
((looking-at "^E: ")
|
||||
(setq out nil))
|
||||
(t
|
||||
(setq cont nil)))
|
||||
(when cont
|
||||
(forward-line)
|
||||
(unless (bolp) (setq cont nil)))
|
||||
(when cont
|
||||
(delete-region 1 4)
|
||||
(setq end (point))
|
||||
(if out
|
||||
(with-current-buffer pbuf
|
||||
(goto-char (point-max))
|
||||
(insert-buffer-substring tbuf 1 end))
|
||||
(with-current-buffer (get-buffer-create ghc-error-buffer)
|
||||
(setq buffer-read-only t)
|
||||
(let* ((buffer-read-only nil)
|
||||
(inhibit-read-only t)
|
||||
(cbuf (current-buffer))
|
||||
cwin)
|
||||
(unless (get-buffer-window cbuf) (display-buffer cbuf))
|
||||
(setq cwin (get-buffer-window cbuf))
|
||||
(with-selected-window cwin
|
||||
(goto-char (point-max))
|
||||
(insert-buffer-substring tbuf 1 end)
|
||||
(set-buffer-modified-p nil)
|
||||
(redisplay)))))
|
||||
(delete-region 1 end)))))
|
||||
(goto-char (point-max))
|
||||
(forward-line -1)
|
||||
(cond
|
||||
((looking-at "^OK$")
|
||||
(if ghc-process-hook (funcall ghc-process-hook))
|
||||
(goto-char (point-min))
|
||||
(funcall ghc-process-callback 'ok)
|
||||
(when ghc-debug
|
||||
(let ((cbuf (current-buffer)))
|
||||
(ghc-with-debug-buffer
|
||||
(insert-buffer-substring cbuf))))
|
||||
(setq ghc-process-running nil))
|
||||
((looking-at "^NG ")
|
||||
(funcall ghc-process-callback 'ng)
|
||||
(when ghc-debug
|
||||
(let ((cbuf (current-buffer)))
|
||||
(ghc-with-debug-buffer
|
||||
(insert-buffer-substring cbuf))))
|
||||
(setq ghc-process-running nil)))))))
|
||||
|
||||
(defun ghc-process-sentinel (process event)
|
||||
|
11
elisp/ghc.el
11
elisp/ghc.el
@ -28,7 +28,7 @@
|
||||
(< emacs-minor-version minor)))
|
||||
(error "ghc-mod requires at least Emacs %d.%d" major minor)))
|
||||
|
||||
(defconst ghc-version "5.2.1.2")
|
||||
(defconst ghc-version "5.3.0.0")
|
||||
|
||||
;; (eval-when-compile
|
||||
;; (require 'haskell-mode))
|
||||
@ -117,6 +117,9 @@
|
||||
(setq ghc-initialized t)
|
||||
(defadvice save-buffer (after ghc-check-syntax-on-save activate)
|
||||
"Check syntax with GHC when a haskell-mode buffer is saved."
|
||||
(when (eq 'haskell-mode major-mode) (ghc-check-syntax)))
|
||||
(defadvice switch-to-buffer (after ghc-check-syntax-on-switch-to-buffer activate)
|
||||
"Check syntax with GHC when switching to a haskell-mode buffer."
|
||||
(when (eq 'haskell-mode major-mode) (ghc-check-syntax))))
|
||||
(ghc-import-module)
|
||||
(ghc-check-syntax))
|
||||
@ -130,23 +133,19 @@
|
||||
(let ((el-path (locate-file "ghc.el" load-path))
|
||||
(ghc-path (executable-find "ghc")) ;; FIXME
|
||||
(ghc-mod-path (executable-find ghc-module-command))
|
||||
(ghc-modi-path (executable-find ghc-interactive-command))
|
||||
(el-ver ghc-version)
|
||||
(ghc-ver (ghc-run-ghc-mod '("--version") "ghc"))
|
||||
(ghc-mod-ver (ghc-run-ghc-mod '("version")))
|
||||
(ghc-modi-ver (ghc-run-ghc-mod '("version") ghc-interactive-command))
|
||||
(path (getenv "PATH")))
|
||||
(switch-to-buffer (get-buffer-create "**GHC Debug**"))
|
||||
(erase-buffer)
|
||||
(insert "Path: check if you are using intended programs.\n")
|
||||
(insert (format "\t ghc.el path: %s\n" el-path))
|
||||
(insert (format "\t ghc-mod path: %s\n" ghc-mod-path))
|
||||
(insert (format "\tghc-modi path: %s\n" ghc-modi-path))
|
||||
(insert (format "\t ghc path: %s\n" ghc-path))
|
||||
(insert "\nVersion: all versions must be the same.\n")
|
||||
(insert "\nVersion: all GHC versions must be the same.\n")
|
||||
(insert (format "\t ghc.el version %s\n" el-ver))
|
||||
(insert (format "\t %s\n" ghc-mod-ver))
|
||||
(insert (format "\t%s\n" ghc-modi-ver))
|
||||
(insert (format "\t%s\n" ghc-ver))
|
||||
(insert "\nEnvironment variables:\n")
|
||||
(insert (format "\tPATH=%s\n" path))))
|
||||
|
208
ghc-mod.cabal
208
ghc-mod.cabal
@ -1,73 +1,102 @@
|
||||
Name: ghc-mod
|
||||
Version: 5.2.1.2
|
||||
Author: Kazu Yamamoto <kazu@iij.ad.jp>
|
||||
Daniel Gröber <dxld@darkboxed.org>
|
||||
Version: 5.3.0.0
|
||||
Author: Kazu Yamamoto <kazu@iij.ad.jp>,
|
||||
Daniel Gröber <dxld@darkboxed.org>,
|
||||
Alejandro Serrano <trupill@gmail.com>
|
||||
Maintainer: Kazu Yamamoto <kazu@iij.ad.jp>
|
||||
License: BSD3
|
||||
Maintainer: Daniel Gröber <dxld@darkboxed.org>
|
||||
License: AGPL-3
|
||||
License-File: LICENSE
|
||||
License-Files: COPYING.BSD3 COPYING.AGPL3
|
||||
Homepage: http://www.mew.org/~kazu/proj/ghc-mod/
|
||||
Synopsis: Happy Haskell Programming
|
||||
Description: The ghc-mod command is a backend command to enrich
|
||||
Haskell programming on editors including
|
||||
Emacs, Vim, and Sublime.
|
||||
The ghc-mod command is based on ghc-mod library
|
||||
which is a wrapper of GHC API.
|
||||
This package includes the ghc-mod command,
|
||||
the ghc-mod library, and Emacs front-end
|
||||
(for historical reasons).
|
||||
Description:
|
||||
ghc-mod is a backend program to enrich Haskell programming in editors. It
|
||||
strives to offer most of the features one has come to expect from modern IDEs
|
||||
in any editor.
|
||||
|
||||
ghc-mod provides a library for other haskell programs to use as well as a
|
||||
standalone program for easy editor integration. All of the fundamental
|
||||
functionality of the frontend program can be accessed through the library
|
||||
however many implementation details are hidden and if you want to
|
||||
significantly extend ghc-mod you should submit these changes upstream instead
|
||||
of implementing them on top of the library.
|
||||
|
||||
For more information, please see its home page.
|
||||
|
||||
Category: Development
|
||||
Cabal-Version: >= 1.10
|
||||
Build-Type: Simple
|
||||
Data-Dir: elisp
|
||||
Data-Files: Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el
|
||||
ghc-check.el ghc-process.el ghc-command.el ghc-info.el
|
||||
ghc-ins-mod.el ghc-indent.el ghc-pkg.el ghc-rewrite.el
|
||||
Category: GHC, Development
|
||||
Cabal-Version: >= 1.14
|
||||
Build-Type: Custom
|
||||
Data-Files: elisp/Makefile
|
||||
elisp/*.el
|
||||
Data-Files: LICENSE COPYING.BSD3 COPYING.AGPL3
|
||||
Extra-Source-Files: ChangeLog
|
||||
test/data/*.cabal
|
||||
test/data/*.hs
|
||||
test/data/cabal.sandbox.config.in
|
||||
test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf
|
||||
SetupCompat.hs
|
||||
NotCPP/*.hs
|
||||
test/data/annotations/*.hs
|
||||
test/data/broken-cabal/*.cabal
|
||||
test/data/broken-cabal/cabal.sandbox.config.in
|
||||
test/data/broken-sandbox/*.cabal
|
||||
test/data/broken-sandbox/cabal.sandbox.config
|
||||
test/data/broken-sandbox/dummy.cabal
|
||||
test/data/cabal-flags/cabal-flags.cabal
|
||||
test/data/cabal-project/*.cabal
|
||||
test/data/cabal-project/*.hs
|
||||
test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/Cabal-1.18.1.3-2b161c6bf77657aa17e1681d83cb051b.conf
|
||||
test/data/cabal-project/cabal.sandbox.config.in
|
||||
test/data/cabal-project/subdir1/subdir2/dummy
|
||||
test/data/case-split/*.hs
|
||||
test/data/cabal-flags/*.cabal
|
||||
test/data/check-packageid/cabal.sandbox.config.in
|
||||
test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf
|
||||
test/data/check-test-subdir/*.cabal
|
||||
test/data/check-test-subdir/src/Check/Test/*.hs
|
||||
test/data/check-test-subdir/test/*.hs
|
||||
test/data/check-test-subdir/test/Bar/*.hs
|
||||
test/data/check-packageid/cabal.sandbox.config.in
|
||||
test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf
|
||||
test/data/duplicate-pkgver/cabal.sandbox.config.in
|
||||
test/data/duplicate-pkgver/duplicate-pkgver.cabal
|
||||
test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-1.0-7c59d13f32294d1ef6dc6233c24df961.conf
|
||||
test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-14e543bdae2da4d2aeff5386892c9112.conf
|
||||
test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d/template-haskell-2.8.0.0-32d4f24abdbb6bf41272b183b2e23e9c.conf
|
||||
test/data/pattern-synonyms/*.cabal
|
||||
test/data/pattern-synonyms/*.hs
|
||||
test/data/foreign-export/*.hs
|
||||
test/data/ghc-mod-check/*.cabal
|
||||
test/data/ghc-mod-check/*.hs
|
||||
test/data/ghc-mod-check/Data/*.hs
|
||||
test/data/subdir1/subdir2/dummy
|
||||
test/data/.cabal-sandbox/packages/00-index.tar
|
||||
test/data/ghc-mod-check/lib/Data/*.hs
|
||||
test/data/hlint/*.hs
|
||||
test/data/home-module-graph/cpp/*.hs
|
||||
test/data/home-module-graph/cycle/*.hs
|
||||
test/data/home-module-graph/errors/*.hs
|
||||
test/data/home-module-graph/indirect/*.hs
|
||||
test/data/home-module-graph/indirect-update/*.hs
|
||||
test/data/import-cycle/*.hs
|
||||
test/data/non-exported/*.hs
|
||||
test/data/pattern-synonyms/*.cabal
|
||||
test/data/pattern-synonyms/*.hs
|
||||
test/data/quasi-quotes/*.hs
|
||||
test/data/template-haskell/*.hs
|
||||
test/data/target/*.hs
|
||||
test/data/check-missing-warnings/*.hs
|
||||
test/data/custom-cradle/custom-cradle.cabal
|
||||
test/data/custom-cradle/ghc-mod.package-db-stack
|
||||
test/data/custom-cradle/package-db-a/.gitkeep
|
||||
test/data/custom-cradle/package-db-b/.gitkeep
|
||||
test/data/custom-cradle/package-db-c/.gitkeep
|
||||
test/data/cabal-preprocessors/*.cabal
|
||||
test/data/cabal-preprocessors/*.hs
|
||||
test/data/cabal-preprocessors/*.hsc
|
||||
|
||||
Library
|
||||
Default-Language: Haskell2010
|
||||
GHC-Options: -Wall
|
||||
Default-Extensions: ConstraintKinds, FlexibleContexts
|
||||
GHC-Options: -Wall -fno-warn-deprecations
|
||||
Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns,
|
||||
ConstraintKinds, FlexibleContexts,
|
||||
DataKinds, KindSignatures, TypeOperators
|
||||
Exposed-Modules: Language.Haskell.GhcMod
|
||||
Language.Haskell.GhcMod.Internal
|
||||
Other-Modules: Language.Haskell.GhcMod.Boot
|
||||
Other-Modules: Paths_ghc_mod
|
||||
Utils
|
||||
Language.Haskell.GhcMod.Boot
|
||||
Language.Haskell.GhcMod.Browse
|
||||
Language.Haskell.GhcMod.Cabal16
|
||||
Language.Haskell.GhcMod.Cabal18
|
||||
Language.Haskell.GhcMod.Cabal21
|
||||
Language.Haskell.GhcMod.CabalApi
|
||||
Language.Haskell.GhcMod.CabalConfig
|
||||
Language.Haskell.GhcMod.CabalHelper
|
||||
Language.Haskell.GhcMod.Caching
|
||||
Language.Haskell.GhcMod.Caching.Types
|
||||
Language.Haskell.GhcMod.CaseSplit
|
||||
Language.Haskell.GhcMod.Check
|
||||
Language.Haskell.GhcMod.Convert
|
||||
@ -79,18 +108,21 @@ Library
|
||||
Language.Haskell.GhcMod.FillSig
|
||||
Language.Haskell.GhcMod.Find
|
||||
Language.Haskell.GhcMod.Flag
|
||||
Language.Haskell.GhcMod.GHCApi
|
||||
Language.Haskell.GhcMod.GHCChoice
|
||||
Language.Haskell.GhcMod.Gap
|
||||
Language.Haskell.GhcMod.GhcPkg
|
||||
Language.Haskell.GhcMod.HomeModuleGraph
|
||||
Language.Haskell.GhcMod.Info
|
||||
Language.Haskell.GhcMod.Lang
|
||||
Language.Haskell.GhcMod.Lint
|
||||
Language.Haskell.GhcMod.Logger
|
||||
Language.Haskell.GhcMod.Logging
|
||||
Language.Haskell.GhcMod.Modules
|
||||
Language.Haskell.GhcMod.Monad
|
||||
Language.Haskell.GhcMod.Monad.Types
|
||||
Language.Haskell.GhcMod.Output
|
||||
Language.Haskell.GhcMod.PathsAndFiles
|
||||
Language.Haskell.GhcMod.PkgDoc
|
||||
Language.Haskell.GhcMod.Pretty
|
||||
Language.Haskell.GhcMod.Read
|
||||
Language.Haskell.GhcMod.SrcUtils
|
||||
Language.Haskell.GhcMod.Target
|
||||
@ -98,7 +130,10 @@ Library
|
||||
Language.Haskell.GhcMod.Utils
|
||||
Language.Haskell.GhcMod.World
|
||||
Build-Depends: base >= 4.0 && < 5
|
||||
, bytestring
|
||||
, cereal >= 0.4
|
||||
, containers
|
||||
, cabal-helper == 0.5.* && >= 0.5.1.0
|
||||
, deepseq
|
||||
, directory
|
||||
, filepath
|
||||
@ -106,7 +141,6 @@ Library
|
||||
, ghc-paths
|
||||
, ghc-syb-utils
|
||||
, hlint >= 1.8.61
|
||||
, io-choice
|
||||
, monad-journal >= 0.4
|
||||
, old-time
|
||||
, pretty
|
||||
@ -117,30 +151,28 @@ Library
|
||||
, transformers
|
||||
, transformers-base
|
||||
, mtl >= 2.0
|
||||
, monad-control
|
||||
, monad-control >= 1
|
||||
, split
|
||||
, haskell-src-exts
|
||||
, text
|
||||
, djinn-ghc >= 0.0.2.2
|
||||
if impl(ghc >= 7.8)
|
||||
Build-Depends: Cabal >= 1.18
|
||||
else
|
||||
, fclabels
|
||||
if impl(ghc < 7.8)
|
||||
Build-Depends: convertible
|
||||
, Cabal >= 1.10 && < 1.17
|
||||
if impl(ghc <= 7.4.2)
|
||||
if impl(ghc < 7.5)
|
||||
-- Only used to constrain random to a version that still works with GHC 7.4
|
||||
Build-Depends: random <= 1.0.1.1
|
||||
Build-Depends: random <= 1.0.1.1,
|
||||
ghc-prim
|
||||
|
||||
Executable ghc-mod
|
||||
Default-Language: Haskell2010
|
||||
Main-Is: GHCMod.hs
|
||||
Other-Modules: Paths_ghc_mod
|
||||
GHC-Options: -Wall
|
||||
GHC-Options: -Wall -fno-warn-deprecations
|
||||
Default-Extensions: ConstraintKinds, FlexibleContexts
|
||||
HS-Source-Dirs: src
|
||||
Build-Depends: base >= 4.0 && < 5
|
||||
, async
|
||||
, data-default
|
||||
, directory
|
||||
, filepath
|
||||
, pretty
|
||||
@ -156,22 +188,17 @@ Executable ghc-modi
|
||||
Other-Modules: Paths_ghc_mod
|
||||
Misc
|
||||
Utils
|
||||
GHC-Options: -Wall -threaded
|
||||
GHC-Options: -Wall -threaded -fno-warn-deprecations
|
||||
if os(windows)
|
||||
Cpp-Options: -DWINDOWS
|
||||
Default-Extensions: ConstraintKinds, FlexibleContexts
|
||||
HS-Source-Dirs: src
|
||||
HS-Source-Dirs: src, .
|
||||
Build-Depends: base >= 4.0 && < 5
|
||||
, async
|
||||
, containers
|
||||
, directory
|
||||
, filepath
|
||||
, old-time
|
||||
, process
|
||||
, split
|
||||
, time
|
||||
, ghc
|
||||
, ghc-mod
|
||||
, old-time
|
||||
|
||||
Test-Suite doctest
|
||||
Type: exitcode-stdio-1.0
|
||||
@ -180,20 +207,27 @@ Test-Suite doctest
|
||||
Ghc-Options: -Wall
|
||||
Default-Extensions: ConstraintKinds, FlexibleContexts
|
||||
Main-Is: doctests.hs
|
||||
if impl(ghc == 7.4.*)
|
||||
Buildable: False
|
||||
Build-Depends: base
|
||||
, doctest >= 0.9.3
|
||||
|
||||
Test-Suite spec
|
||||
Default-Language: Haskell2010
|
||||
Default-Extensions: ConstraintKinds, FlexibleContexts
|
||||
Default-Extensions: ScopedTypeVariables, RecordWildCards, NamedFieldPuns,
|
||||
ConstraintKinds, FlexibleContexts,
|
||||
DataKinds, KindSignatures, TypeOperators
|
||||
Main-Is: Main.hs
|
||||
Hs-Source-Dirs: test, .
|
||||
Ghc-Options: -Wall
|
||||
Ghc-Options: -Wall -fno-warn-deprecations
|
||||
CPP-Options: -DSPEC=1
|
||||
Type: exitcode-stdio-1.0
|
||||
Other-Modules: BrowseSpec
|
||||
CabalApiSpec
|
||||
CheckSpec
|
||||
Other-Modules: Paths_ghc_mod
|
||||
Dir
|
||||
Spec
|
||||
TestUtils
|
||||
BrowseSpec
|
||||
CheckSpec
|
||||
FlagSpec
|
||||
InfoSpec
|
||||
LangSpec
|
||||
@ -201,42 +235,14 @@ Test-Suite spec
|
||||
ListSpec
|
||||
MonadSpec
|
||||
PathsAndFilesSpec
|
||||
Spec
|
||||
TestUtils
|
||||
Build-Depends: base >= 4.0 && < 5
|
||||
, containers
|
||||
, deepseq
|
||||
, directory
|
||||
, filepath
|
||||
, ghc
|
||||
, ghc-paths
|
||||
, ghc-syb-utils
|
||||
, hlint >= 1.7.1
|
||||
, io-choice
|
||||
, monad-journal >= 0.4
|
||||
, old-time
|
||||
, pretty
|
||||
, process
|
||||
, syb
|
||||
, temporary
|
||||
, time
|
||||
, transformers
|
||||
, transformers-base
|
||||
, mtl >= 2.0
|
||||
, monad-control
|
||||
, hspec >= 1.8.2
|
||||
, split
|
||||
, haskell-src-exts
|
||||
, text
|
||||
, djinn-ghc >= 0.0.2.2
|
||||
if impl(ghc >= 7.8)
|
||||
Build-Depends: Cabal >= 1.18
|
||||
else
|
||||
Build-Depends: convertible
|
||||
, Cabal >= 1.10 && < 1.17
|
||||
if impl(ghc < 7.6)
|
||||
HomeModuleGraphSpec
|
||||
|
||||
Build-Depends: hspec >= 2.0.0
|
||||
if impl(ghc == 7.4.*)
|
||||
Build-Depends: executable-path
|
||||
CPP-Options: -DSPEC=1
|
||||
X-Build-Depends-Like: CLibName
|
||||
|
||||
|
||||
|
||||
Source-Repository head
|
||||
Type: git
|
||||
|
51
ghcmodHappyHaskellProgram-Dg.tex
Normal file
51
ghcmodHappyHaskellProgram-Dg.tex
Normal 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}
|
@ -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}
|
@ -1,5 +1,7 @@
|
||||
#!/bin/sh
|
||||
|
||||
set -e
|
||||
|
||||
if [ -z "$1" ]; then
|
||||
echo "Usage: $0 VERSION" >&2
|
||||
exit 1
|
||||
@ -19,6 +21,13 @@ sed -i 's/(defconst ghc-version ".*")/(defconst ghc-version "'"$VERSION"'")/' \
|
||||
|
||||
sed -r -i 's/^(Version:[[:space:]]*)[0-9.]+/\1'"$VERSION"'/' ghc-mod.cabal
|
||||
|
||||
git add elisp/ghc.el ghc-mod.cabal
|
||||
git commit -m "Bump version to $VERSION"
|
||||
|
||||
git checkout release
|
||||
#git merge master
|
||||
git merge -s recursive -X theirs master
|
||||
|
||||
( tac ChangeLog; echo "\n$(date '+%Y-%m-%d') v$VERSION" ) | tac \
|
||||
> ChangeLog.tmp
|
||||
|
||||
@ -26,6 +35,8 @@ mv ChangeLog.tmp ChangeLog
|
||||
|
||||
emacs -q -nw ChangeLog
|
||||
|
||||
git add ChangeLog elisp/ghc.el ghc-mod.cabal
|
||||
git commit -m "Bump version to $VERSION"
|
||||
git add ChangeLog
|
||||
git commit -m "ChangeLog"
|
||||
|
||||
|
||||
git tag "v$VERSION"
|
||||
|
36
scripts/compare-versions.sh
Normal file
36
scripts/compare-versions.sh
Normal 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
|
477
src/GHCMod.hs
477
src/GHCMod.hs
@ -6,41 +6,40 @@ import Config (cProjectVersion)
|
||||
import MonadUtils (liftIO)
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import Control.Exception ( SomeException(..), fromException, Exception
|
||||
, Handler(..), catches, throw)
|
||||
import Data.Typeable (Typeable)
|
||||
import Data.Version (showVersion)
|
||||
import Data.Default
|
||||
import Data.List
|
||||
import Data.List.Split
|
||||
import Data.Maybe
|
||||
import Data.Char (isSpace)
|
||||
import Data.Maybe
|
||||
import Exception
|
||||
import Language.Haskell.GhcMod
|
||||
import Language.Haskell.GhcMod.Internal
|
||||
import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
|
||||
import Paths_ghc_mod
|
||||
import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))
|
||||
import qualified System.Console.GetOpt as O
|
||||
import System.Directory (setCurrentDirectory)
|
||||
import System.Environment (getArgs,getProgName)
|
||||
import System.FilePath ((</>))
|
||||
import System.Directory (setCurrentDirectory, getAppUserDataDirectory,
|
||||
removeDirectoryRecursive)
|
||||
import System.Environment (getArgs)
|
||||
import System.Exit (exitFailure)
|
||||
import System.IO (hPutStrLn, stdout, stderr, hSetEncoding, utf8, hFlush)
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import System.FilePath (takeFileName)
|
||||
import System.Exit (ExitCode, exitSuccess)
|
||||
import System.IO (stdout, hSetEncoding, utf8, hFlush)
|
||||
import System.Exit (exitSuccess)
|
||||
import Text.PrettyPrint
|
||||
import Prelude
|
||||
|
||||
import Misc
|
||||
|
||||
|
||||
|
||||
progVersion :: String
|
||||
progVersion =
|
||||
progName ++ " version " ++ showVersion version ++ " compiled by GHC "
|
||||
progVersion :: String -> String
|
||||
progVersion pf =
|
||||
"ghc-mod"++pf++" version " ++ showVersion version ++ " compiled by GHC "
|
||||
++ cProjectVersion ++ "\n"
|
||||
|
||||
-- TODO: remove (ghc) version prefix!
|
||||
progName :: String
|
||||
progName = unsafePerformIO $ takeFileName <$> getProgName
|
||||
ghcModVersion :: String
|
||||
ghcModVersion = progVersion ""
|
||||
|
||||
ghcModiVersion :: String
|
||||
ghcModiVersion = progVersion "i"
|
||||
|
||||
optionUsage :: (String -> String) -> [OptDescr a] -> [String]
|
||||
optionUsage indent opts = concatMap optUsage opts
|
||||
@ -65,33 +64,27 @@ optionUsage indent opts = concatMap optUsage opts
|
||||
ReqArg _ label -> s ++ label
|
||||
OptArg _ label -> s ++ "["++label++"]"
|
||||
|
||||
-- TODO: Generate the stuff below automatically
|
||||
usage :: String
|
||||
usage =
|
||||
case progName of
|
||||
"ghc-modi" -> ghcModiUsage
|
||||
_ -> ghcModUsage
|
||||
|
||||
-- TODO: Generate the stuff below automatically
|
||||
ghcModUsage :: String
|
||||
ghcModUsage =
|
||||
"Usage: ghc-mod [OPTIONS...] COMMAND [OPTIONS...] \n\
|
||||
"Usage: ghc-mod [OPTIONS...] COMMAND [CMD_ARGS...] \n\
|
||||
\*Global Options (OPTIONS)*\n\
|
||||
\ Global options can be specified before and after the command and\n\
|
||||
\ interspersed with command specific options\n\
|
||||
\\n"
|
||||
++ (unlines $ indent <$> optionUsage indent globalArgSpec) ++
|
||||
"*Commands*\n\
|
||||
\ - version | --version\n\
|
||||
\ - version\n\
|
||||
\ Print the version of the program.\n\
|
||||
\\n\
|
||||
\ - help | --help\n\
|
||||
\ - help\n\
|
||||
\ Print this help message.\n\
|
||||
\\n\
|
||||
\ - list [FLAGS...] | modules [FLAGS...]\n\
|
||||
\ List all visible modules.\n\
|
||||
\ Flags:\n\
|
||||
\ -d\n\
|
||||
\ Also print the modules' package.\n\
|
||||
\ Print package modules belong to.\n\
|
||||
\\n\
|
||||
\ - lang\n\
|
||||
\ List all known GHC language extensions.\n\
|
||||
@ -183,12 +176,12 @@ ghcModUsage =
|
||||
\ -l\n\
|
||||
\ Option to be passed to hlint.\n\
|
||||
\\n\
|
||||
\ - root FILE\n\
|
||||
\ Try to find the project directory given FILE. For Cabal\n\
|
||||
\ projects this is the directory containing the cabal file, for\n\
|
||||
\ projects that use a cabal sandbox but have no cabal file this is the\n\
|
||||
\ directory containing the sandbox and otherwise this is the directory\n\
|
||||
\ containing FILE.\n\
|
||||
\ - root\n\
|
||||
\ Try to find the project directory. For Cabal projects this is the\n\
|
||||
\ directory containing the cabal file, for projects that use a cabal\n\
|
||||
\ sandbox but have no cabal file this is the directory containing the\n\
|
||||
\ cabal.sandbox.config file and otherwise this is the current\n\
|
||||
\ directory.\n\
|
||||
\\n\
|
||||
\ - doc MODULE\n\
|
||||
\ Try finding the html documentation directory for the given MODULE.\n\
|
||||
@ -197,57 +190,46 @@ ghcModUsage =
|
||||
\ Print debugging information. Please include the output in any bug\n\
|
||||
\ reports you submit.\n\
|
||||
\\n\
|
||||
\ - boot\n\
|
||||
\ Internal command used by the emacs frontend.\n"
|
||||
-- "\n\
|
||||
-- \The following forms are supported so ghc-mod can be invoked by\n\
|
||||
-- \`cabal repl':\n\
|
||||
-- \\n\
|
||||
-- \ ghc-mod --make GHC_OPTIONS\n\
|
||||
-- \ Pass all options through to the GHC executable.\n\
|
||||
-- \\n\
|
||||
-- \ ghc-mod --interactive GHC_OPTIONS [--ghc-mod]\n\
|
||||
-- \ Start ghci emulation mode. GHC_OPTIONS are passed to the\n\
|
||||
-- \ GHC API. If `--ghc-mod' is given ghc-mod specific extensions\n\
|
||||
-- \ are enabled.\n"
|
||||
where
|
||||
indent = (" "++)
|
||||
|
||||
ghcModiUsage :: String
|
||||
ghcModiUsage =
|
||||
"Usage: ghc-modi [OPTIONS...] COMMAND\n\
|
||||
\*Options*\n"
|
||||
++ (unlines $ indent <$> optionUsage indent globalArgSpec) ++
|
||||
"*Commands*\n\
|
||||
\ - version | --version\n\
|
||||
\ Print the version of the program.\n\
|
||||
\ - debugComponent [MODULE_OR_FILE...]\n\
|
||||
\ Debugging information related to cabal component resolution.\n\
|
||||
\\n\
|
||||
\ - help | --help\n\
|
||||
\ Print this help message.\n"
|
||||
\ - boot\n\
|
||||
\ Internal command used by the emacs frontend.\n\
|
||||
\\n\
|
||||
\ - legacy-interactive\n\
|
||||
\ ghc-modi compatibility mode.\n"
|
||||
where
|
||||
indent = (" "++)
|
||||
|
||||
|
||||
|
||||
|
||||
cmdUsage :: String -> String -> String
|
||||
cmdUsage cmd s =
|
||||
cmdUsage cmd realUsage =
|
||||
let
|
||||
-- Find command head
|
||||
a = dropWhile (not . ((" - " ++ cmd) `isInfixOf`)) $ lines s
|
||||
a = dropWhile (not . isCmdHead) $ lines realUsage
|
||||
-- Take til the end of the current command block
|
||||
b = flip takeWhile a $ \l ->
|
||||
all isSpace l || (isIndented l && (isCurrCmdHead l || isNotCmdHead l))
|
||||
all isSpace l || (isIndented l && (isCmdHead l || isNotCmdHead l))
|
||||
-- Drop extra newline from the end
|
||||
c = dropWhileEnd (all isSpace) b
|
||||
|
||||
isIndented = (" " `isPrefixOf`)
|
||||
isNotCmdHead = ( not . (" - " `isPrefixOf`))
|
||||
isCurrCmdHead = ((" - " ++ cmd) `isPrefixOf`)
|
||||
|
||||
containsAnyCmdHead s = ((" - ") `isInfixOf` s)
|
||||
containsCurrCmdHead s = ((" - " ++ cmd) `isInfixOf` s)
|
||||
isCmdHead s =
|
||||
containsAnyCmdHead s &&
|
||||
or [ containsCurrCmdHead s
|
||||
, any (cmd `isPrefixOf`) (splitOn " | " s)
|
||||
]
|
||||
|
||||
unindent (' ':' ':' ':' ':l) = l
|
||||
unindent l = l
|
||||
in unlines $ unindent <$> c
|
||||
|
||||
ghcModStyle :: Style
|
||||
ghcModStyle = style { lineLength = 80, ribbonsPerLine = 1.2 }
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
option :: [Char] -> [String] -> String -> ArgDescr a -> OptDescr a
|
||||
@ -256,43 +238,78 @@ option s l udsc dsc = Option s l dsc udsc
|
||||
reqArg :: String -> (String -> a) -> ArgDescr a
|
||||
reqArg udsc dsc = ReqArg dsc udsc
|
||||
|
||||
globalArgSpec :: [OptDescr (Options -> Options)]
|
||||
optArg :: String -> (Maybe String -> a) -> ArgDescr a
|
||||
optArg udsc dsc = OptArg dsc udsc
|
||||
|
||||
intToLogLevel :: Int -> GmLogLevel
|
||||
intToLogLevel = toEnum
|
||||
|
||||
globalArgSpec :: [OptDescr (Options -> Either [String] Options)]
|
||||
globalArgSpec =
|
||||
[ option "v" ["verbose"] "Be more verbose." $
|
||||
NoArg $ \o -> o { ghcUserOptions = "-v" : ghcUserOptions o }
|
||||
[ option "v" ["verbose"] "Increase or set log level. (0-7)" $
|
||||
optArg "LEVEL" $ \ml o -> Right $ o {
|
||||
logLevel = case ml of
|
||||
Nothing -> increaseLogLevel (logLevel o)
|
||||
Just l -> toEnum $ min 7 $ read l
|
||||
}
|
||||
|
||||
, option "s" [] "Be silent, set log level to 0" $
|
||||
NoArg $ \o -> Right $ o { logLevel = toEnum 0 }
|
||||
|
||||
, option "l" ["tolisp"] "Format output as an S-Expression" $
|
||||
NoArg $ \o -> o { outputStyle = LispStyle }
|
||||
NoArg $ \o -> Right $ o { outputStyle = LispStyle }
|
||||
|
||||
, option "b" ["boundary"] "Output line separator"$
|
||||
reqArg "SEP" $ \s o -> o { lineSeparator = LineSeparator s }
|
||||
, option "b" ["boundary", "line-seperator"] "Output line separator"$
|
||||
reqArg "SEP" $ \s o -> Right $ o { lineSeparator = LineSeparator s }
|
||||
, option "" ["line-prefix"] "Output line separator"$
|
||||
reqArg "OUT,ERR" $ \s o -> let
|
||||
[out, err] = splitOn "," s
|
||||
in Right $ o { linePrefix = Just (out, err) }
|
||||
|
||||
, option "g" ["ghcOpt"] "Option to be passed to GHC" $
|
||||
reqArg "OPT" $ \g o ->
|
||||
, option "g" ["ghcOpt", "ghc-option"] "Option to be passed to GHC" $
|
||||
reqArg "OPT" $ \g o -> Right $
|
||||
o { ghcUserOptions = g : ghcUserOptions o }
|
||||
|
||||
, option "" ["with-ghc"] "GHC executable to use" $
|
||||
reqArg "PROG" $ \p o -> o { ghcProgram = p }
|
||||
reqArg "PROG" $ \p o -> Right $ o { ghcProgram = p }
|
||||
|
||||
, option "" ["with-ghc-pkg"] "ghc-pkg executable to use (only needed when guessing from GHC path fails)" $
|
||||
reqArg "PROG" $ \p o -> Right $ o { ghcPkgProgram = p }
|
||||
|
||||
, option "" ["with-cabal"] "cabal-install executable to use" $
|
||||
reqArg "PROG" $ \p o -> o { cabalProgram = p }
|
||||
reqArg "PROG" $ \p o -> Right $ o { cabalProgram = p }
|
||||
|
||||
, option "" ["version"] "print version information" $
|
||||
NoArg $ \_ -> Left ["version"]
|
||||
|
||||
, option "" ["help"] "print this help message" $
|
||||
NoArg $ \_ -> Left ["help"]
|
||||
|
||||
]
|
||||
|
||||
|
||||
parseGlobalArgs :: [String] -> Either InvalidCommandLine (Options, [String])
|
||||
parseGlobalArgs argv
|
||||
= case O.getOpt RequireOrder globalArgSpec argv of
|
||||
(o,r,[] ) -> Right $ (foldr id defaultOptions o, r)
|
||||
(_,_,errs) -> Left $ InvalidCommandLine $ Right $
|
||||
"Parsing command line options failed: " ++ concat errs
|
||||
= case O.getOpt' RequireOrder globalArgSpec argv of
|
||||
(o,r,u,[]) -> case foldr (=<<) (Right defaultOptions) o of
|
||||
Right o' -> Right (o', u ++ r)
|
||||
Left c -> Right (defaultOptions, c)
|
||||
(_,_,u,e) -> Left $ InvalidCommandLine $ Right $
|
||||
"Parsing command line options failed: "
|
||||
++ concat (e ++ map errUnrec u)
|
||||
where
|
||||
errUnrec :: String -> String
|
||||
errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n"
|
||||
|
||||
parseCommandArgs :: [OptDescr (Options -> Options)]
|
||||
parseCommandArgs :: [OptDescr (Options -> Either [String] Options)]
|
||||
-> [String]
|
||||
-> Options
|
||||
-> (Options, [String])
|
||||
parseCommandArgs spec argv opts
|
||||
= case O.getOpt RequireOrder (globalArgSpec ++ spec) argv of
|
||||
(o,r,[]) -> (foldr id opts o, r)
|
||||
(o,r,[]) -> case foldr (=<<) (Right opts) o of
|
||||
Right o' -> (o', r)
|
||||
Left c -> (defaultOptions, c)
|
||||
(_,_,errs) ->
|
||||
fatalError $ "Parsing command options failed: " ++ concat errs
|
||||
|
||||
@ -306,121 +323,65 @@ data CmdError = UnknownCommand String
|
||||
|
||||
instance Exception CmdError
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
data InteractiveOptions = InteractiveOptions {
|
||||
ghcModExtensions :: Bool
|
||||
}
|
||||
|
||||
instance Default InteractiveOptions where
|
||||
def = InteractiveOptions False
|
||||
|
||||
handler :: IO a -> IO a
|
||||
handler = flip catches $
|
||||
[ Handler $ \(FatalError msg) -> exitError msg
|
||||
, Handler $ \(InvalidCommandLine e) -> do
|
||||
handler :: IOish m => GhcModT m a -> GhcModT m a
|
||||
handler = flip gcatches $
|
||||
[ GHandler $ \(FatalError msg) -> exitError msg
|
||||
, GHandler $ \(InvalidCommandLine e) -> do
|
||||
case e of
|
||||
Left cmd ->
|
||||
exitError $ (cmdUsage cmd ghcModUsage) ++ "\n"
|
||||
++ progName ++ ": Invalid command line form."
|
||||
Right msg -> exitError $ progName ++ ": " ++ msg
|
||||
exitError $ "Usage for `"++cmd++"' command:\n\n"
|
||||
++ (cmdUsage cmd usage) ++ "\n"
|
||||
++ "ghc-mod: Invalid command line form."
|
||||
Right msg -> exitError $ "ghc-mod: " ++ msg
|
||||
, GHandler $ \(SomeException e) -> exitError $ "ghc-mod: " ++ show e
|
||||
]
|
||||
|
||||
main :: IO ()
|
||||
main = handler $ do
|
||||
main = do
|
||||
hSetEncoding stdout utf8
|
||||
args <- getArgs
|
||||
|
||||
-- This doesn't handle --help and --version being given after any global
|
||||
-- options. To do that we'd have to fiddle with getOpt.
|
||||
case parseGlobalArgs args of
|
||||
Left e -> case globalCommands args of
|
||||
Just s -> putStr s
|
||||
Nothing -> throw e
|
||||
|
||||
Right res@(_,cmdArgs) ->
|
||||
case globalCommands cmdArgs of
|
||||
Just s -> putStr s
|
||||
Nothing -> progMain res
|
||||
Left e -> throw e
|
||||
Right res -> progMain res
|
||||
|
||||
progMain :: (Options,[String]) -> IO ()
|
||||
progMain (globalOptions,cmdArgs) = do
|
||||
-- let (ghcArgs, modArgs) = second stripSeperator $ span (/="--") args
|
||||
-- _realGhcArgs = filter (/="--ghc-mod") ghcArgs
|
||||
|
||||
-- (globalOptions,_cmdArgs) = parseGlobalArgs modArgs
|
||||
|
||||
-- stripSeperator ("--":rest) = rest
|
||||
-- stripSeperator l = l
|
||||
|
||||
case progName of
|
||||
"ghc-modi" -> do
|
||||
legacyInteractive globalOptions =<< emptyNewUnGetLine
|
||||
|
||||
|
||||
_
|
||||
-- | "--numeric-version" `elem` ghcArgs || "--make" `elem` ghcArgs -> do
|
||||
-- rawSystem (ghcProgram globalOptions) realGhcArgs >>= exitWith
|
||||
|
||||
-- | "--interactive" `elem` ghcArgs -> do
|
||||
-- let interactiveOptions = if "--ghc-mod" `elem` ghcArgs
|
||||
-- then def { ghcModExtensions = True }
|
||||
-- else def
|
||||
|
||||
-- -- TODO: pass ghcArgs' to ghc API
|
||||
-- putStrLn "\ninteractive\n"
|
||||
-- --print realGhcArgs
|
||||
-- (res, _) <- runGhcModT globalOptions $ undefined
|
||||
-- case res of
|
||||
-- Right s -> putStr s
|
||||
-- Left e -> exitError $ render (gmeDoc e)
|
||||
|
||||
|
||||
| otherwise -> do
|
||||
(res,_) <- runGhcModT globalOptions $ ghcCommands cmdArgs
|
||||
case res of
|
||||
Right s -> putStr s
|
||||
Left e -> exitError $ render (gmeDoc e)
|
||||
|
||||
-- Obtain ghc options by letting ourselfs be executed by
|
||||
-- @cabal repl@
|
||||
-- TODO: need to do something about non-cabal projects
|
||||
-- exe <- ghcModExecutable
|
||||
-- let cabalArgs = ["repl", "-v0", "--with-ghc="++exe]
|
||||
-- ++ (("--ghc-option="++) `map` ("--ghc-mod":"--":args))
|
||||
|
||||
-- print cabalArgs
|
||||
|
||||
-- rawSystem "cabal" cabalArgs >>= exitWith
|
||||
|
||||
progMain (globalOptions,cmdArgs) = hndle $ runGhcModT globalOptions $ handler $ do
|
||||
case globalCommands cmdArgs of
|
||||
Just s -> gmPutStr s
|
||||
Nothing -> ghcCommands cmdArgs
|
||||
where
|
||||
hndle action = do
|
||||
(e, _l) <- action
|
||||
case e of
|
||||
Right _ ->
|
||||
return ()
|
||||
Left ed ->
|
||||
exitError' globalOptions $ renderStyle ghcModStyle (gmeDoc ed)
|
||||
|
||||
globalCommands :: [String] -> Maybe String
|
||||
globalCommands (cmd:_)
|
||||
| cmd == "help" = Just usage
|
||||
| cmd == "version" = Just ghcModVersion
|
||||
globalCommands _ = Nothing
|
||||
|
||||
-- ghc-modi
|
||||
legacyInteractive :: Options -> UnGetLine -> IO ()
|
||||
legacyInteractive opt ref = flip catches handlers $ do
|
||||
(res,_) <- runGhcModT opt $ do
|
||||
symdbreq <- liftIO $ newSymDbReq opt
|
||||
world <- liftIO . getCurrentWorld =<< cradle
|
||||
legacyInteractiveLoop symdbreq ref world
|
||||
legacyInteractive :: IOish m => GhcModT m ()
|
||||
legacyInteractive = do
|
||||
opt <- options
|
||||
prepareCabalHelper
|
||||
tmpdir <- cradleTempDir <$> cradle
|
||||
symdbreq <- liftIO $ newSymDbReq opt tmpdir
|
||||
world <- getCurrentWorld
|
||||
legacyInteractiveLoop symdbreq world
|
||||
|
||||
case res of
|
||||
Right () -> return ()
|
||||
Left e -> putStrLn $ notGood $ render (gmeDoc e)
|
||||
|
||||
where
|
||||
handlers = [ Handler $ \Restart -> legacyInteractive opt ref ]
|
||||
|
||||
isExitCodeException :: SomeException -> Bool
|
||||
isExitCodeException e = isJust mExitCode
|
||||
where
|
||||
mExitCode :: Maybe ExitCode
|
||||
mExitCode = fromException e
|
||||
|
||||
|
||||
bug :: String -> IO ()
|
||||
bug :: IOish m => String -> GhcModT m ()
|
||||
bug msg = do
|
||||
putStrLn $ notGood $ "BUG: " ++ msg
|
||||
exitFailure
|
||||
gmPutStrLn $ notGood $ "BUG: " ++ msg
|
||||
liftIO exitFailure
|
||||
|
||||
notGood :: String -> String
|
||||
notGood msg = "NG " ++ escapeNewlines msg
|
||||
@ -431,30 +392,26 @@ escapeNewlines = replace "\n" "\\n" . replace "\\n" "\\\\n"
|
||||
replace :: String -> String -> String -> String
|
||||
replace needle replacement = intercalate replacement . splitOn needle
|
||||
|
||||
|
||||
legacyInteractiveLoop :: IOish m
|
||||
=> SymDbReq -> UnGetLine -> World -> GhcModT m ()
|
||||
legacyInteractiveLoop symdbreq ref world = do
|
||||
=> SymDbReq -> World -> GhcModT m ()
|
||||
legacyInteractiveLoop symdbreq world = do
|
||||
liftIO . setCurrentDirectory =<< cradleRootDir <$> cradle
|
||||
|
||||
-- blocking
|
||||
cmdArg <- liftIO $ getCommand ref
|
||||
cmdArg <- liftIO $ getLine
|
||||
|
||||
-- after blocking, we need to see if the world has changed.
|
||||
|
||||
changed <- liftIO . didWorldChange world =<< cradle
|
||||
changed <- didWorldChange world
|
||||
when changed $ do
|
||||
liftIO $ ungetCommand ref cmdArg
|
||||
throw Restart
|
||||
|
||||
liftIO . prepareAutogen =<< cradle
|
||||
dropSession
|
||||
|
||||
let (cmd':args') = split (keepDelimsR $ condense $ whenElt isSpace) cmdArg
|
||||
arg = concat args'
|
||||
cmd = dropWhileEnd isSpace cmd'
|
||||
args = dropWhileEnd isSpace `map` args'
|
||||
|
||||
res <- case dropWhileEnd isSpace cmd of
|
||||
res <- flip gcatches interactiveHandlers $ case dropWhileEnd isSpace cmd of
|
||||
"check" -> checkSyntaxCmd [arg]
|
||||
"lint" -> lintCmd [arg]
|
||||
"find" -> do
|
||||
@ -476,22 +433,20 @@ legacyInteractiveLoop symdbreq ref world = do
|
||||
"" -> liftIO $ exitSuccess
|
||||
_ -> fatalError $ "unknown command: `" ++ cmd ++ "'"
|
||||
|
||||
liftIO $ putStr res >> putStrLn "OK" >> hFlush stdout
|
||||
legacyInteractiveLoop symdbreq ref world
|
||||
|
||||
|
||||
globalCommands :: [String] -> Maybe String
|
||||
globalCommands [] = Nothing
|
||||
globalCommands (cmd:_) = case cmd of
|
||||
_ | cmd == "help" || cmd == "--help" -> Just usage
|
||||
_ | cmd == "version" || cmd == "--version" -> Just progVersion
|
||||
_ -> Nothing
|
||||
|
||||
ghcCommands :: IOish m => [String] -> GhcModT m String
|
||||
ghcCommands [] = fatalError "No command given (try --help)"
|
||||
ghcCommands (cmd:args) = fn args
|
||||
gmPutStr res >> gmPutStrLn "OK" >> liftIO (hFlush stdout)
|
||||
legacyInteractiveLoop symdbreq world
|
||||
where
|
||||
fn = case cmd of
|
||||
interactiveHandlers =
|
||||
[ GHandler $ \e@(FatalError _) -> throw e
|
||||
, GHandler $ \(SomeException e) -> gmErrStrLn (show e) >> return ""
|
||||
]
|
||||
|
||||
ghcCommands :: IOish m => [String] -> GhcModT m ()
|
||||
ghcCommands [] = fatalError "No command given (try --help)"
|
||||
ghcCommands (cmd:args) = do
|
||||
gmPutStr =<< action args
|
||||
where
|
||||
action = case cmd of
|
||||
_ | cmd == "list" || cmd == "modules" -> modulesCmd
|
||||
"lang" -> languagesCmd
|
||||
"flag" -> flagsCmd
|
||||
@ -499,6 +454,7 @@ ghcCommands (cmd:args) = fn args
|
||||
"check" -> checkSyntaxCmd
|
||||
"expand" -> expandTemplateCmd
|
||||
"debug" -> debugInfoCmd
|
||||
"debug-component" -> componentInfoCmd
|
||||
"info" -> infoCmd
|
||||
"type" -> typesCmd
|
||||
"split" -> splitsCmd
|
||||
@ -511,6 +467,8 @@ ghcCommands (cmd:args) = fn args
|
||||
"doc" -> pkgDocCmd
|
||||
"dumpsym" -> dumpSymbolCmd
|
||||
"boot" -> bootCmd
|
||||
"legacy-interactive" -> legacyInteractiveCmd
|
||||
-- "nuke-caches" -> nukeCachesCmd
|
||||
_ -> fatalError $ "unknown command: `" ++ cmd ++ "'"
|
||||
|
||||
newtype FatalError = FatalError String deriving (Show, Typeable)
|
||||
@ -520,14 +478,18 @@ newtype InvalidCommandLine = InvalidCommandLine (Either String String)
|
||||
deriving (Show, Typeable)
|
||||
instance Exception InvalidCommandLine
|
||||
|
||||
exitError :: String -> IO a
|
||||
exitError msg = hPutStrLn stderr msg >> exitFailure
|
||||
exitError :: IOish m => String -> GhcModT m a
|
||||
exitError msg = gmErrStrLn (dropWhileEnd (=='\n') msg) >> liftIO exitFailure
|
||||
|
||||
exitError' :: Options -> String -> IO a
|
||||
exitError' opts msg =
|
||||
gmUnsafeErrStrLn opts (dropWhileEnd (=='\n') msg) >> liftIO exitFailure
|
||||
|
||||
fatalError :: String -> a
|
||||
fatalError s = throw $ FatalError $ progName ++ ": " ++ s
|
||||
fatalError s = throw $ FatalError $ "ghc-mod: " ++ s
|
||||
|
||||
withParseCmd :: IOish m
|
||||
=> [OptDescr (Options -> Options)]
|
||||
=> [OptDescr (Options -> Either [String] Options)]
|
||||
-> ([String] -> GhcModT m a)
|
||||
-> [String]
|
||||
-> GhcModT m a
|
||||
@ -535,23 +497,41 @@ withParseCmd spec action args = do
|
||||
(opts', rest) <- parseCommandArgs spec args <$> options
|
||||
withOptions (const opts') $ action rest
|
||||
|
||||
withParseCmd' :: (IOish m, ExceptionMonad m)
|
||||
=> String
|
||||
-> [OptDescr (Options -> Either [String] Options)]
|
||||
-> ([String] -> GhcModT m a)
|
||||
-> [String]
|
||||
-> GhcModT m a
|
||||
withParseCmd' cmd spec action args =
|
||||
catchArgs cmd $ withParseCmd spec action args
|
||||
|
||||
catchArgs :: (Monad m, ExceptionMonad m) => String -> m a -> m a
|
||||
catchArgs cmd action =
|
||||
action `gcatch` \(PatternMatchFail _) ->
|
||||
throw $ InvalidCommandLine (Left cmd)
|
||||
|
||||
modulesCmd, languagesCmd, flagsCmd, browseCmd, checkSyntaxCmd, expandTemplateCmd,
|
||||
debugInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd, refineCmd, autoCmd,
|
||||
findSymbolCmd, lintCmd, rootInfoCmd, pkgDocCmd, dumpSymbolCmd, bootCmd
|
||||
debugInfoCmd, componentInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd,
|
||||
refineCmd, autoCmd, findSymbolCmd, lintCmd, rootInfoCmd, pkgDocCmd,
|
||||
dumpSymbolCmd, bootCmd, legacyInteractiveCmd, nukeCachesCmd
|
||||
:: IOish m => [String] -> GhcModT m String
|
||||
|
||||
modulesCmd = withParseCmd [] $ \[] -> modules
|
||||
languagesCmd = withParseCmd [] $ \[] -> languages
|
||||
flagsCmd = withParseCmd [] $ \[] -> flags
|
||||
debugInfoCmd = withParseCmd [] $ \[] -> debugInfo
|
||||
rootInfoCmd = withParseCmd [] $ \[] -> rootInfo
|
||||
modulesCmd = withParseCmd' "modules" s $ \[] -> modules
|
||||
where s = modulesArgSpec
|
||||
languagesCmd = withParseCmd' "lang" [] $ \[] -> languages
|
||||
flagsCmd = withParseCmd' "flag" [] $ \[] -> flags
|
||||
debugInfoCmd = withParseCmd' "debug" [] $ \[] -> debugInfo
|
||||
rootInfoCmd = withParseCmd' "root" [] $ \[] -> rootInfo
|
||||
componentInfoCmd = withParseCmd' "debugComponent" [] $ \ts -> componentInfo ts
|
||||
-- internal
|
||||
bootCmd = withParseCmd [] $ \[] -> boot
|
||||
bootCmd = withParseCmd' "boot" [] $ \[] -> boot
|
||||
nukeCachesCmd = withParseCmd' "nuke-caches" [] $ \[] -> nukeCaches >> return ""
|
||||
|
||||
dumpSymbolCmd = withParseCmd [] $ \[tmpdir] -> dumpSymbol tmpdir
|
||||
findSymbolCmd = withParseCmd [] $ \[sym] -> findSymbol sym
|
||||
pkgDocCmd = withParseCmd [] $ \[mdl] -> pkgDoc mdl
|
||||
lintCmd = withParseCmd s $ \[file] -> lint file
|
||||
dumpSymbolCmd = withParseCmd' "dump" [] $ \[tmpdir] -> dumpSymbol tmpdir
|
||||
findSymbolCmd = withParseCmd' "find" [] $ \[sym] -> findSymbol sym
|
||||
pkgDocCmd = withParseCmd' "doc" [] $ \[mdl] -> pkgDoc mdl
|
||||
lintCmd = withParseCmd' "lint" s $ \[file] -> lint file
|
||||
where s = hlintArgSpec
|
||||
browseCmd = withParseCmd s $ \mdls -> concat <$> browse `mapM` mdls
|
||||
where s = browseArgSpec
|
||||
@ -565,10 +545,20 @@ autoCmd = withParseCmd [] $ locAction "auto" auto
|
||||
refineCmd = withParseCmd [] $ locAction' "refine" refine
|
||||
|
||||
infoCmd = withParseCmd [] $ action
|
||||
where action [file,_,expr] = info file expr
|
||||
action [file,expr] = info file expr
|
||||
where action [file,_,expr] = info file $ Expression expr
|
||||
action [file,expr] = info file $ Expression expr
|
||||
action _ = throw $ InvalidCommandLine (Left "info")
|
||||
|
||||
legacyInteractiveCmd = withParseCmd [] go
|
||||
where
|
||||
go [] =
|
||||
legacyInteractive >> return ""
|
||||
go ("help":[]) =
|
||||
return usage
|
||||
go ("version":[]) =
|
||||
return ghcModiVersion
|
||||
go _ = throw $ InvalidCommandLine (Left "legacy-interactive")
|
||||
|
||||
checkAction :: ([t] -> a) -> [t] -> a
|
||||
checkAction _ [] = throw $ InvalidCommandLine (Right "No files given.")
|
||||
checkAction action files = action files
|
||||
@ -578,22 +568,43 @@ locAction _ action [file,_,line,col] = action file (read line) (read col)
|
||||
locAction _ action [file, line,col] = action file (read line) (read col)
|
||||
locAction cmd _ _ = throw $ InvalidCommandLine (Left cmd)
|
||||
|
||||
locAction' :: String -> (String -> Int -> Int -> String -> a) -> [String] -> a
|
||||
locAction' _ action [f,_,line,col,expr] = action f (read line) (read col) expr
|
||||
locAction' _ action [f, line,col,expr] = action f (read line) (read col) expr
|
||||
locAction' :: String -> (String -> Int -> Int -> Expression -> a) -> [String] -> a
|
||||
locAction' _ action [f,_,line,col,expr] = action f (read line) (read col) (Expression expr)
|
||||
locAction' _ action [f, line,col,expr] = action f (read line) (read col) (Expression expr)
|
||||
locAction' cmd _ _ = throw $ InvalidCommandLine (Left cmd)
|
||||
|
||||
hlintArgSpec :: [OptDescr (Options -> Options)]
|
||||
|
||||
modulesArgSpec :: [OptDescr (Options -> Either [String] Options)]
|
||||
modulesArgSpec =
|
||||
[ option "d" ["detailed"] "Print package modules belong to." $
|
||||
NoArg $ \o -> Right $ o { detailed = True }
|
||||
]
|
||||
|
||||
|
||||
hlintArgSpec :: [OptDescr (Options -> Either [String] Options)]
|
||||
hlintArgSpec =
|
||||
[ option "h" ["hlintOpt"] "Option to be passed to hlint" $
|
||||
reqArg "hlintOpt" $ \h o -> o { hlintOpts = h : hlintOpts o }
|
||||
reqArg "hlintOpt" $ \h o -> Right $ o { hlintOpts = h : hlintOpts o }
|
||||
]
|
||||
browseArgSpec :: [OptDescr (Options -> Options)]
|
||||
|
||||
browseArgSpec :: [OptDescr (Options -> Either [String] Options)]
|
||||
browseArgSpec =
|
||||
[ option "o" ["operators"] "Also print operators." $
|
||||
NoArg $ \o -> o { operators = True }
|
||||
NoArg $ \o -> Right $ o { operators = True }
|
||||
, option "d" ["detailed"] "Print symbols with accompanying signature." $
|
||||
NoArg $ \o -> o { detailed = True }
|
||||
NoArg $ \o -> Right $ o { detailed = True }
|
||||
, option "q" ["qualified"] "Qualify symbols" $
|
||||
NoArg $ \o -> o { qualified = True }
|
||||
NoArg $ \o -> Right $ o { qualified = True }
|
||||
]
|
||||
|
||||
nukeCaches :: IOish m => GhcModT m ()
|
||||
nukeCaches = do
|
||||
chdir <- liftIO $ (</> "cabal-helper") <$> getAppUserDataDirectory "ghc-mod"
|
||||
c <- cradle
|
||||
|
||||
when (cradleProjectType c == CabalProject) $ do
|
||||
let root = cradleRootDir c
|
||||
liftIO $ (trySome . removeDirectoryRecursive) `mapM_` [chdir, root </> "dist"]
|
||||
|
||||
trySome :: IO a -> IO (Either SomeException a)
|
||||
trySome = try
|
||||
|
289
src/GHCModi.hs
289
src/GHCModi.hs
@ -1,262 +1,55 @@
|
||||
{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
|
||||
|
||||
-- | WARNING
|
||||
-- This program in the process of being deprecated, use `ghc-mod --interactive`
|
||||
-- instead.
|
||||
|
||||
-- Commands:
|
||||
-- check <file>
|
||||
-- find <symbol>
|
||||
-- info <file> <expr>
|
||||
-- type <file> <line> <column>
|
||||
-- lint [hlint options] <file>
|
||||
-- the format of hlint options is [String] because they may contain
|
||||
-- spaces and also <file> may contain spaces.
|
||||
-- boot
|
||||
-- browse [<package>:]<module>
|
||||
-- quit
|
||||
--
|
||||
-- Session separators:
|
||||
-- OK -- success
|
||||
-- NG -- failure
|
||||
-- This program is deprecated, use `ghc-mod legacy-interactive` instead.
|
||||
|
||||
module Main where
|
||||
|
||||
import Config (cProjectVersion)
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Exception (SomeException(..))
|
||||
import qualified Control.Exception as E
|
||||
import Control.Monad (when)
|
||||
import CoreMonad (liftIO)
|
||||
import Data.List (intercalate)
|
||||
import Data.List.Split (splitOn)
|
||||
import Data.Version (showVersion)
|
||||
import Language.Haskell.GhcMod
|
||||
import Language.Haskell.GhcMod.Internal
|
||||
import Control.Applicative
|
||||
import Control.Monad
|
||||
import Control.Exception
|
||||
import Data.Version
|
||||
import Data.Maybe
|
||||
import System.IO
|
||||
import System.Exit
|
||||
import System.Process
|
||||
import System.FilePath
|
||||
import System.Environment
|
||||
import Paths_ghc_mod
|
||||
import System.Console.GetOpt
|
||||
import System.Directory (setCurrentDirectory)
|
||||
import System.Environment (getArgs)
|
||||
import System.Exit (ExitCode, exitFailure)
|
||||
import System.IO (hFlush,stdout)
|
||||
|
||||
import Misc
|
||||
import Utils
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
progVersion :: String
|
||||
progVersion = "ghc-modi version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n"
|
||||
|
||||
argspec :: [OptDescr (Options -> Options)]
|
||||
argspec = [ Option "b" ["boundary"]
|
||||
(ReqArg (\s opts -> opts { lineSeparator = LineSeparator s }) "sep")
|
||||
"specify line separator (default is Nul string)"
|
||||
, Option "l" ["tolisp"]
|
||||
(NoArg (\opts -> opts { outputStyle = LispStyle }))
|
||||
"print as a list of Lisp"
|
||||
, Option "g" []
|
||||
(ReqArg (\s opts -> opts { ghcUserOptions = s : ghcUserOptions opts }) "flag") "specify a ghc flag"
|
||||
]
|
||||
|
||||
usage :: String
|
||||
usage = progVersion
|
||||
++ "Usage:\n"
|
||||
++ "\t ghc-modi [-l] [-b sep] [-g flag]\n"
|
||||
++ "\t ghc-modi version\n"
|
||||
++ "\t ghc-modi help\n"
|
||||
|
||||
parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String])
|
||||
parseArgs spec argv
|
||||
= case getOpt Permute spec argv of
|
||||
(o,n,[] ) -> (foldr id defaultOptions o, n)
|
||||
(_,_,errs) -> E.throw (CmdArg errs)
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
-- Running two GHC monad threads disables the handling of
|
||||
-- C-c since installSignalHandlers is called twice, sigh.
|
||||
import Prelude
|
||||
|
||||
main :: IO ()
|
||||
main = E.handle cmdHandler $
|
||||
go =<< parseArgs argspec <$> getArgs
|
||||
where
|
||||
cmdHandler (CmdArg _) = putStr $ usageInfo usage argspec
|
||||
go (_,"help":_) = putStr $ usageInfo usage argspec
|
||||
go (_,"version":_) = putStr progVersion
|
||||
go (opt,_) = emptyNewUnGetLine >>= run opt
|
||||
main = do
|
||||
hPutStrLn stderr $
|
||||
"Warning: ghc-modi is deprecated please use 'ghc-mod legacy-interactive' instead"
|
||||
|
||||
run :: Options -> UnGetLine -> IO ()
|
||||
run opt ref = flip E.catches handlers $ do
|
||||
cradle0 <- findCradle
|
||||
let rootdir = cradleRootDir cradle0
|
||||
-- c = cradle0 { cradleCurrentDir = rootdir } TODO: ?????
|
||||
setCurrentDirectory rootdir
|
||||
prepareAutogen cradle0
|
||||
-- Asynchronous db loading starts here.
|
||||
symdbreq <- newSymDbReq opt
|
||||
(res, _) <- runGhcModT opt $ do
|
||||
crdl <- cradle
|
||||
world <- liftIO $ getCurrentWorld crdl
|
||||
loop symdbreq ref world
|
||||
case res of
|
||||
Right () -> return ()
|
||||
Left (GMECabalConfigure msg) -> do
|
||||
putStrLn $ notGood $ "cabal configure failed: " ++ show msg
|
||||
exitFailure
|
||||
Left e -> bug $ show e
|
||||
where
|
||||
-- this is just in case.
|
||||
-- If an error is caught here, it is a bug of GhcMod library.
|
||||
handlers = [ E.Handler (\(_ :: ExitCode) -> return ())
|
||||
, E.Handler (\(_ :: Restart) -> run opt ref)
|
||||
, E.Handler (\(SomeException e) -> bug $ show e) ]
|
||||
args <- getArgs
|
||||
bindir <- getBinDir
|
||||
let installedExe = bindir </> "ghc-mod"
|
||||
mexe <- mplus <$> mightExist installedExe <*> pathExe
|
||||
case mexe of
|
||||
Nothing -> do
|
||||
hPutStrLn stderr $
|
||||
"ghc-modi: Could not find '"++installedExe++"', check your installation!"
|
||||
exitWith $ ExitFailure 1
|
||||
|
||||
bug :: String -> IO ()
|
||||
bug msg = do
|
||||
putStrLn $ notGood $ "BUG: " ++ msg
|
||||
exitFailure
|
||||
Just exe -> do
|
||||
(_, _, _, h) <-
|
||||
createProcess $ proc exe $ ["legacy-interactive"] ++ args
|
||||
exitWith =<< waitForProcess h
|
||||
|
||||
notGood :: String -> String
|
||||
notGood msg = "NG " ++ escapeNewlines msg
|
||||
pathExe :: IO (Maybe String)
|
||||
pathExe = do
|
||||
ev <- try $ words <$> readProcess "ghc-mod" ["--version"] ""
|
||||
let mexe = case ev of
|
||||
Left (SomeException _) -> Nothing
|
||||
Right ["ghc-mod", "version", ver
|
||||
, "compiled", "by", "GHC", _]
|
||||
| showVersion version == ver -> do
|
||||
Just "ghc-mod"
|
||||
Right _ -> Nothing
|
||||
|
||||
escapeNewlines :: String -> String
|
||||
escapeNewlines = replace "\n" "\\n" . replace "\\n" "\\\\n"
|
||||
|
||||
replace :: String -> String -> String -> String
|
||||
replace needle replacement = intercalate replacement . splitOn needle
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
loop :: IOish m => SymDbReq -> UnGetLine -> World -> GhcModT m ()
|
||||
loop symdbreq ref world = do
|
||||
-- blocking
|
||||
cmdArg <- liftIO $ getCommand ref
|
||||
-- after blocking, we need to see if the world has changed.
|
||||
crdl <- cradle
|
||||
changed <- liftIO $ didWorldChange world crdl
|
||||
when changed $ do
|
||||
liftIO $ ungetCommand ref cmdArg
|
||||
E.throw Restart
|
||||
cradle >>= liftIO . prepareAutogen
|
||||
let (cmd,arg') = break (== ' ') cmdArg
|
||||
arg = dropWhile (== ' ') arg'
|
||||
(ret,ok) <- case cmd of
|
||||
"check" -> checkStx arg
|
||||
"find" -> findSym arg symdbreq
|
||||
"lint" -> lintStx arg
|
||||
"info" -> showInfo arg
|
||||
"type" -> showType arg
|
||||
"split" -> doSplit arg
|
||||
"sig" -> doSig arg
|
||||
"refine" -> doRefine arg
|
||||
"auto" -> doAuto arg
|
||||
"boot" -> bootIt
|
||||
"browse" -> browseIt arg
|
||||
"quit" -> return ("quit", False)
|
||||
"" -> return ("quit", False)
|
||||
_ -> return ([], True)
|
||||
if ok then do
|
||||
liftIO $ putStr ret
|
||||
liftIO $ putStrLn "OK"
|
||||
else do
|
||||
liftIO $ putStrLn $ notGood ret
|
||||
liftIO $ hFlush stdout
|
||||
when ok $ loop symdbreq ref world
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
checkStx :: IOish m => FilePath -> GhcModT m (String, Bool)
|
||||
checkStx file = do
|
||||
eret <- check [file]
|
||||
case eret of
|
||||
Right ret -> return (ret, True)
|
||||
Left ret -> return (ret, True)
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
findSym :: IOish m => Symbol -> SymDbReq -> GhcModT m (String, Bool)
|
||||
findSym sym symdbreq = do
|
||||
db <- getDb symdbreq >>= checkDb symdbreq
|
||||
ret <- lookupSymbol sym db
|
||||
return (ret, True)
|
||||
|
||||
lintStx :: IOish m => FilePath -> GhcModT m (String, Bool)
|
||||
lintStx optFile = do
|
||||
ret <- withOptions changeOpt $ lint file
|
||||
return (ret, True)
|
||||
where
|
||||
(opts,file) = parseLintOptions optFile
|
||||
hopts = if opts == "" then [] else read opts
|
||||
changeOpt o = o { hlintOpts = hopts }
|
||||
|
||||
-- |
|
||||
-- >>> parseLintOptions "[\"--ignore=Use camelCase\", \"--ignore=Eta reduce\"] file name"
|
||||
-- (["--ignore=Use camelCase", "--ignore=Eta reduce"], "file name")
|
||||
-- >>> parseLintOptions "file name"
|
||||
-- ([], "file name")
|
||||
parseLintOptions :: String -> (String, String)
|
||||
parseLintOptions optFile = case brk (== ']') (dropWhile (/= '[') optFile) of
|
||||
("","") -> ([], optFile)
|
||||
(opt',file') -> (opt', dropWhile (== ' ') file')
|
||||
where
|
||||
brk _ [] = ([],[])
|
||||
brk p (x:xs')
|
||||
| p x = ([x],xs')
|
||||
| otherwise = let (ys,zs) = brk p xs' in (x:ys,zs)
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
showInfo :: IOish m => FilePath -> GhcModT m (String, Bool)
|
||||
showInfo fileArg = do
|
||||
let [file, expr] = splitN 2 fileArg
|
||||
ret <- info file expr
|
||||
return (ret, True)
|
||||
|
||||
showType :: IOish m => FilePath -> GhcModT m (String, Bool)
|
||||
showType fileArg = do
|
||||
let [file, line, column] = splitN 3 fileArg
|
||||
ret <- types file (read line) (read column)
|
||||
return (ret, True)
|
||||
|
||||
doSplit :: IOish m => FilePath -> GhcModT m (String, Bool)
|
||||
doSplit fileArg = do
|
||||
let [file, line, column] = splitN 3 fileArg
|
||||
ret <- splits file (read line) (read column)
|
||||
return (ret, True)
|
||||
|
||||
doSig :: IOish m => FilePath -> GhcModT m (String, Bool)
|
||||
doSig fileArg = do
|
||||
let [file, line, column] = splitN 3 fileArg
|
||||
ret <- sig file (read line) (read column)
|
||||
return (ret, True)
|
||||
|
||||
doRefine :: IOish m => FilePath -> GhcModT m (String, Bool)
|
||||
doRefine fileArg = do
|
||||
let [file, line, column, expr] = splitN 4 fileArg
|
||||
ret <- refine file (read line) (read column) expr
|
||||
return (ret, True)
|
||||
|
||||
doAuto :: IOish m => FilePath -> GhcModT m (String, Bool)
|
||||
doAuto fileArg = do
|
||||
let [file, line, column] = splitN 3 fileArg
|
||||
ret <- auto file (read line) (read column)
|
||||
return (ret, True)
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
bootIt :: IOish m => GhcModT m (String, Bool)
|
||||
bootIt = do
|
||||
ret <- boot
|
||||
return (ret, True)
|
||||
|
||||
browseIt :: IOish m => ModuleString -> GhcModT m (String, Bool)
|
||||
browseIt mdl = do
|
||||
let (det,rest') = break (== ' ') mdl
|
||||
rest = dropWhile (== ' ') rest'
|
||||
ret <- if det == "-d"
|
||||
then withOptions setDetailed (browse rest)
|
||||
else browse mdl
|
||||
return (ret, True)
|
||||
where
|
||||
setDetailed opt = opt { detailed = True }
|
||||
when (isNothing mexe) $
|
||||
hPutStrLn stderr "ghc-modi: ghc-mod executable on PATH has different version, check your installation!"
|
||||
return mexe
|
||||
|
121
src/Misc.hs
121
src/Misc.hs
@ -1,75 +1,28 @@
|
||||
{-# LANGUAGE DeriveDataTypeable, CPP #-}
|
||||
|
||||
module Misc (
|
||||
GHCModiError(..)
|
||||
, Restart(..)
|
||||
, UnGetLine
|
||||
, emptyNewUnGetLine
|
||||
, ungetCommand
|
||||
, getCommand
|
||||
, SymDbReq
|
||||
SymDbReq
|
||||
, newSymDbReq
|
||||
, getDb
|
||||
, checkDb
|
||||
, prepareAutogen
|
||||
) where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Concurrent.Async (Async, async, wait)
|
||||
import Control.Exception (Exception)
|
||||
import Control.Monad (unless, when)
|
||||
import CoreMonad (liftIO)
|
||||
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
|
||||
import Data.List (isPrefixOf)
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Typeable (Typeable)
|
||||
import System.Directory (doesDirectoryExist, getDirectoryContents)
|
||||
import System.IO (openBinaryFile, IOMode(..))
|
||||
import System.Process
|
||||
import Prelude
|
||||
|
||||
import Language.Haskell.GhcMod
|
||||
import Language.Haskell.GhcMod.Internal
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
data GHCModiError = CmdArg [String] deriving (Show, Typeable)
|
||||
|
||||
instance Exception GHCModiError
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
data Restart = Restart deriving (Show, Typeable)
|
||||
|
||||
instance Exception Restart
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
newtype UnGetLine = UnGetLine (IORef (Maybe String))
|
||||
|
||||
emptyNewUnGetLine :: IO UnGetLine
|
||||
emptyNewUnGetLine = UnGetLine <$> newIORef Nothing
|
||||
|
||||
ungetCommand :: UnGetLine -> String -> IO ()
|
||||
ungetCommand (UnGetLine ref) cmd = writeIORef ref (Just cmd)
|
||||
|
||||
getCommand :: UnGetLine -> IO String
|
||||
getCommand (UnGetLine ref) = do
|
||||
mcmd <- readIORef ref
|
||||
case mcmd of
|
||||
Nothing -> getLine
|
||||
Just cmd -> do
|
||||
writeIORef ref Nothing
|
||||
return cmd
|
||||
import Language.Haskell.GhcMod.Internal hiding (MonadIO,liftIO)
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
type SymDbReqAction = (Either GhcModError SymbolDb, GhcModLog)
|
||||
data SymDbReq = SymDbReq (IORef (Async SymDbReqAction)) (IO SymDbReqAction)
|
||||
|
||||
newSymDbReq :: Options -> IO SymDbReq
|
||||
newSymDbReq opt = do
|
||||
let act = runGhcModT opt loadSymbolDb
|
||||
newSymDbReq :: Options -> FilePath -> IO SymDbReq
|
||||
newSymDbReq opt dir = do
|
||||
let act = runGhcModT opt $ loadSymbolDb dir
|
||||
req <- async act
|
||||
ref <- newIORef req
|
||||
return $ SymDbReq ref act
|
||||
@ -83,7 +36,7 @@ getDb (SymDbReq ref _) = do
|
||||
|
||||
checkDb :: IOish m => SymDbReq -> SymbolDb -> GhcModT m SymbolDb
|
||||
checkDb (SymDbReq ref act) db = do
|
||||
outdated <- liftIO $ isOutdated db
|
||||
outdated <- isOutdated db
|
||||
if outdated then do
|
||||
-- async and wait here is unnecessary because this is essentially
|
||||
-- synchronous. But Async can be used a cache.
|
||||
@ -92,63 +45,3 @@ checkDb (SymDbReq ref act) db = do
|
||||
hoistGhcModT =<< liftIO (wait req)
|
||||
else
|
||||
return db
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
build :: IO ProcessHandle
|
||||
build = do
|
||||
#ifdef WINDOWS
|
||||
nul <- openBinaryFile "NUL" AppendMode
|
||||
#else
|
||||
nul <- openBinaryFile "/dev/null" AppendMode
|
||||
#endif
|
||||
(_, _, _, hdl) <- createProcess $ pro nul
|
||||
return hdl
|
||||
where
|
||||
pro nul = CreateProcess {
|
||||
cmdspec = RawCommand "cabal" ["build"]
|
||||
, cwd = Nothing
|
||||
, env = Nothing
|
||||
, std_in = Inherit
|
||||
, std_out = UseHandle nul
|
||||
, std_err = UseHandle nul
|
||||
, close_fds = False
|
||||
#if __GLASGOW_HASKELL__ >= 702
|
||||
, create_group = True
|
||||
#endif
|
||||
#if __GLASGOW_HASKELL__ >= 707
|
||||
, delegate_ctlc = False
|
||||
#endif
|
||||
}
|
||||
|
||||
autogen :: String
|
||||
autogen = "dist/build/autogen"
|
||||
|
||||
isAutogenPrepared :: IO Bool
|
||||
isAutogenPrepared = do
|
||||
exist <- doesDirectoryExist autogen
|
||||
if exist then do
|
||||
files <- filter ("." `isPrefixOf`) <$> getDirectoryContents autogen
|
||||
if length files >= 2 then
|
||||
return True
|
||||
else
|
||||
return False
|
||||
else
|
||||
return False
|
||||
|
||||
watch :: Int -> ProcessHandle -> IO ()
|
||||
watch 0 _ = return ()
|
||||
watch n hdl = do
|
||||
prepared <- isAutogenPrepared
|
||||
if prepared then
|
||||
interruptProcessGroupOf hdl
|
||||
else do
|
||||
threadDelay 100000
|
||||
watch (n - 1) hdl
|
||||
|
||||
prepareAutogen :: Cradle -> IO ()
|
||||
prepareAutogen crdl = when (isJust $ cradleCabalFile crdl) $ do
|
||||
prepared <- isAutogenPrepared
|
||||
unless prepared $ do
|
||||
hdl <- build
|
||||
watch 30 hdl
|
||||
|
27
src/Utils.hs
27
src/Utils.hs
@ -1,27 +0,0 @@
|
||||
module Utils where
|
||||
|
||||
-- |
|
||||
--
|
||||
-- >>> split "foo bar baz"
|
||||
-- ["foo","bar baz"]
|
||||
-- >>> split "foo bar baz"
|
||||
-- ["foo","bar baz"]
|
||||
split :: String -> [String]
|
||||
split xs = [ys, dropWhile isSpace zs]
|
||||
where
|
||||
isSpace = (== ' ')
|
||||
(ys,zs) = break isSpace xs
|
||||
|
||||
-- |
|
||||
--
|
||||
-- >>> splitN 0 "foo bar baz"
|
||||
-- ["foo","bar baz"]
|
||||
-- >>> splitN 2 "foo bar baz"
|
||||
-- ["foo","bar baz"]
|
||||
-- >>> splitN 3 "foo bar baz"
|
||||
-- ["foo","bar","baz"]
|
||||
splitN :: Int -> String -> [String]
|
||||
splitN n xs
|
||||
| n <= 2 = split xs
|
||||
| otherwise = let [ys,zs] = split xs
|
||||
in ys : splitN (n - 1) zs
|
@ -26,7 +26,8 @@ spec = do
|
||||
syms `shouldContain` ["Left :: a -> Either a b"]
|
||||
|
||||
describe "`browse' in a project directory" $ do
|
||||
it "lists symbols defined in a a local module (e.g. `Baz.baz)" $ do
|
||||
withDirectory_ "test/data" $ do
|
||||
syms <- runID $ lines <$> browse "Baz"
|
||||
syms `shouldContain` ["baz"]
|
||||
it "can list symbols defined in a a local module" $ do
|
||||
withDirectory_ "test/data/ghc-mod-check/lib" $ do
|
||||
syms <- runD $ lines <$> browse "Data.Foo"
|
||||
syms `shouldContain` ["foo"]
|
||||
syms `shouldContain` ["fibonacci"]
|
||||
|
@ -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
96
test/CabalHelperSpec.hs
Normal 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
|
@ -1,9 +1,10 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
module CheckSpec where
|
||||
|
||||
import Data.List (isSuffixOf, isInfixOf, isPrefixOf)
|
||||
import Language.Haskell.GhcMod
|
||||
import System.FilePath
|
||||
|
||||
import Data.List
|
||||
import System.Process
|
||||
import Test.Hspec
|
||||
|
||||
import TestUtils
|
||||
@ -14,38 +15,55 @@ spec = do
|
||||
describe "checkSyntax" $ do
|
||||
it "works even if an executable depends on the library defined in the same cabal file" $ do
|
||||
withDirectory_ "test/data/ghc-mod-check" $ do
|
||||
res <- runID $ checkSyntax ["main.hs"]
|
||||
res <- runD $ checkSyntax ["main.hs"]
|
||||
res `shouldBe` "main.hs:5:1:Warning: Top-level binding with no type signature: main :: IO ()\n"
|
||||
|
||||
|
||||
it "works even if a module imports another module from a different directory" $ do
|
||||
withDirectory_ "test/data/check-test-subdir" $ do
|
||||
res <- runID $ checkSyntax ["test/Bar/Baz.hs"]
|
||||
_ <- system "cabal configure --enable-tests"
|
||||
res <- runD $ checkSyntax ["test/Bar/Baz.hs"]
|
||||
res `shouldSatisfy` (("test" </> "Foo.hs:3:1:Warning: Top-level binding with no type signature: foo :: [Char]\n") `isSuffixOf`)
|
||||
|
||||
it "detects cyclic imports" $ do
|
||||
withDirectory_ "test/data" $ do
|
||||
res <- runID $ checkSyntax ["Mutual1.hs"]
|
||||
withDirectory_ "test/data/import-cycle" $ do
|
||||
res <- runD $ checkSyntax ["Mutual1.hs"]
|
||||
res `shouldSatisfy` ("Module imports form a cycle" `isInfixOf`)
|
||||
|
||||
it "works with modules using QuasiQuotes" $ do
|
||||
withDirectory_ "test/data" $ do
|
||||
res <- runID $ checkSyntax ["Baz.hs"]
|
||||
res `shouldSatisfy` ("Baz.hs:5:1:Warning:" `isPrefixOf`)
|
||||
withDirectory_ "test/data/quasi-quotes" $ do
|
||||
res <- runD $ checkSyntax ["QuasiQuotes.hs"]
|
||||
res `shouldSatisfy` ("QuasiQuotes.hs:6:1:Warning:" `isInfixOf`)
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 708
|
||||
it "works with modules using PatternSynonyms" $ do
|
||||
withDirectory_ "test/data/pattern-synonyms" $ do
|
||||
res <- runID $ checkSyntax ["B.hs"]
|
||||
res <- runD $ checkSyntax ["B.hs"]
|
||||
res `shouldSatisfy` ("B.hs:6:9:Warning:" `isPrefixOf`)
|
||||
#endif
|
||||
|
||||
it "works with foreign exports" $ do
|
||||
withDirectory_ "test/data" $ do
|
||||
res <- runID $ checkSyntax ["ForeignExport.hs"]
|
||||
withDirectory_ "test/data/foreign-export" $ do
|
||||
res <- runD $ checkSyntax ["ForeignExport.hs"]
|
||||
res `shouldBe` ""
|
||||
|
||||
context "when no errors are found" $ do
|
||||
it "doesn't output an empty line" $ do
|
||||
withDirectory_ "test/data/ghc-mod-check/Data" $ do
|
||||
res <- runID $ checkSyntax ["Foo.hs"]
|
||||
withDirectory_ "test/data/ghc-mod-check/lib/Data" $ do
|
||||
res <- runD $ checkSyntax ["Foo.hs"]
|
||||
res `shouldBe` ""
|
||||
|
||||
#if __GLASGOW_HASKELL__ >= 708
|
||||
-- See https://github.com/kazu-yamamoto/ghc-mod/issues/507
|
||||
it "emits warnings generated in GHC's desugar stage" $ do
|
||||
withDirectory_ "test/data/check-missing-warnings" $ do
|
||||
res <- runD $ checkSyntax ["DesugarWarnings.hs"]
|
||||
res `shouldBe` "DesugarWarnings.hs:4:9:Warning: Pattern match(es) are non-exhaustive\NULIn a case alternative: Patterns not matched: _ : _\n"
|
||||
#endif
|
||||
|
||||
it "works with cabal builtin preprocessors" $ do
|
||||
withDirectory_ "test/data/cabal-preprocessors" $ do
|
||||
_ <- system "cabal clean"
|
||||
_ <- system "cabal build"
|
||||
res <- runD $ checkSyntax ["Main.hs"]
|
||||
res `shouldBe` "Preprocessed.hsc:3:1:Warning: Top-level binding with no type signature: warning :: ()\n"
|
||||
|
@ -4,46 +4,23 @@ import Control.Applicative
|
||||
import Data.List (isSuffixOf)
|
||||
import Language.Haskell.GhcMod.Cradle
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import System.Directory (canonicalizePath,getCurrentDirectory)
|
||||
import System.FilePath ((</>), pathSeparator)
|
||||
import System.Directory (canonicalizePath)
|
||||
import System.FilePath (pathSeparator)
|
||||
import Test.Hspec
|
||||
|
||||
import Dir
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "findCradle" $ do
|
||||
it "returns the current directory" $ do
|
||||
withDirectory_ "/" $ do
|
||||
curDir <- stripLastDot <$> canonicalizePath "/"
|
||||
res <- findCradle
|
||||
cradleCurrentDir res `shouldBe` curDir
|
||||
cradleRootDir res `shouldBe` curDir
|
||||
cradleCabalFile res `shouldBe` Nothing
|
||||
cradlePkgDbStack res `shouldBe` [GlobalDb,UserDb]
|
||||
|
||||
it "finds a cabal file and a sandbox" $ do
|
||||
cwd <- getCurrentDirectory
|
||||
withDirectory "test/data/subdir1/subdir2" $ \dir -> do
|
||||
res <- relativeCradle dir <$> findCradle
|
||||
cradleCurrentDir res `shouldBe` "test" </> "data" </> "subdir1" </> "subdir2"
|
||||
cradleRootDir res `shouldBe` "test" </> "data"
|
||||
cradleCabalFile res `shouldBe` Just ("test" </> "data" </> "cabalapi.cabal")
|
||||
cradlePkgDbStack res `shouldBe` [GlobalDb, PackageDb (cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d")]
|
||||
|
||||
it "works even if a sandbox config file is broken" $ do
|
||||
withDirectory "test/data/broken-sandbox" $ \dir -> do
|
||||
res <- relativeCradle dir <$> findCradle
|
||||
cradleCurrentDir res `shouldBe` "test" </> "data" </> "broken-sandbox"
|
||||
cradleRootDir res `shouldBe` "test" </> "data" </> "broken-sandbox"
|
||||
cradleCabalFile res `shouldBe` Just ("test" </> "data" </> "broken-sandbox" </> "dummy.cabal")
|
||||
cradlePkgDbStack res `shouldBe` [GlobalDb, UserDb]
|
||||
clean_ :: IO Cradle -> IO Cradle
|
||||
clean_ f = do
|
||||
crdl <- f
|
||||
cleanupCradle crdl
|
||||
return crdl
|
||||
|
||||
relativeCradle :: FilePath -> Cradle -> Cradle
|
||||
relativeCradle dir cradle = cradle {
|
||||
cradleCurrentDir = toRelativeDir dir $ cradleCurrentDir cradle
|
||||
, cradleRootDir = toRelativeDir dir $ cradleRootDir cradle
|
||||
, cradleCabalFile = toRelativeDir dir <$> cradleCabalFile cradle
|
||||
relativeCradle dir crdl = crdl {
|
||||
cradleCurrentDir = toRelativeDir dir $ cradleCurrentDir crdl
|
||||
, cradleRootDir = toRelativeDir dir $ cradleRootDir crdl
|
||||
, cradleCabalFile = toRelativeDir dir <$> cradleCabalFile crdl
|
||||
}
|
||||
|
||||
-- Work around GHC 7.2.2 where `canonicalizePath "/"` returns "/.".
|
||||
@ -51,3 +28,38 @@ stripLastDot :: FilePath -> FilePath
|
||||
stripLastDot path
|
||||
| (pathSeparator:'.':"") `isSuffixOf` path = init path
|
||||
| otherwise = path
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "findCradle" $ do
|
||||
it "returns the current directory" $ do
|
||||
withDirectory_ "/" $ do
|
||||
curDir <- stripLastDot <$> canonicalizePath "/"
|
||||
res <- clean_ findCradle
|
||||
cradleCurrentDir res `shouldBe` curDir
|
||||
cradleRootDir res `shouldBe` curDir
|
||||
cradleCabalFile res `shouldBe` Nothing
|
||||
|
||||
it "finds a cabal file and a sandbox" $ do
|
||||
withDirectory "test/data/cabal-project/subdir1/subdir2" $ \dir -> do
|
||||
res <- relativeCradle dir <$> clean_ findCradle
|
||||
|
||||
cradleCurrentDir res `shouldBe`
|
||||
"test/data/cabal-project/subdir1/subdir2"
|
||||
|
||||
cradleRootDir res `shouldBe` "test/data/cabal-project"
|
||||
|
||||
cradleCabalFile res `shouldBe`
|
||||
Just ("test/data/cabal-project/cabalapi.cabal")
|
||||
|
||||
it "works even if a sandbox config file is broken" $ do
|
||||
withDirectory "test/data/broken-sandbox" $ \dir -> do
|
||||
res <- relativeCradle dir <$> clean_ findCradle
|
||||
cradleCurrentDir res `shouldBe`
|
||||
"test" </> "data" </> "broken-sandbox"
|
||||
|
||||
cradleRootDir res `shouldBe`
|
||||
"test" </> "data" </> "broken-sandbox"
|
||||
|
||||
cradleCabalFile res `shouldBe`
|
||||
Just ("test" </> "data" </> "broken-sandbox" </> "dummy.cabal")
|
||||
|
10
test/Dir.hs
10
test/Dir.hs
@ -1,9 +1,15 @@
|
||||
module Dir where
|
||||
module Dir (
|
||||
module Dir
|
||||
, getCurrentDirectory
|
||||
, (</>)
|
||||
) where
|
||||
|
||||
import Control.Exception as E
|
||||
import Data.List (isPrefixOf)
|
||||
import System.Directory
|
||||
import System.FilePath (addTrailingPathSeparator)
|
||||
import System.FilePath (addTrailingPathSeparator,(</>))
|
||||
|
||||
|
||||
|
||||
withDirectory_ :: FilePath -> IO a -> IO a
|
||||
withDirectory_ dir action = bracket getCurrentDirectory
|
||||
|
@ -1,6 +1,7 @@
|
||||
module FindSpec where
|
||||
|
||||
import Language.Haskell.GhcMod.Find
|
||||
import Control.Monad
|
||||
import Test.Hspec
|
||||
import TestUtils
|
||||
|
||||
@ -8,5 +9,5 @@ spec :: Spec
|
||||
spec = do
|
||||
describe "db <- loadSymbolDb" $ do
|
||||
it "lookupSymbol' db \"head\" contains at least `Data.List'" $ do
|
||||
db <- runD loadSymbolDb
|
||||
lookupSym "head" db `shouldContain` ["Data.List"]
|
||||
db <- runD $ loadSymbolDb =<< (cradleTempDir `liftM` cradle)
|
||||
lookupSym "head" db `shouldContain` [ModuleString "Data.List"]
|
||||
|
@ -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
30
test/GhcPkgSpec.hs
Normal 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
178
test/HomeModuleGraphSpec.hs
Normal 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
|
||||
]
|
@ -9,51 +9,43 @@ import System.Environment.Executable (getExecutablePath)
|
||||
#else
|
||||
import System.Environment (getExecutablePath)
|
||||
#endif
|
||||
import System.Exit
|
||||
import System.FilePath
|
||||
import System.Process
|
||||
import Test.Hspec
|
||||
import TestUtils
|
||||
import Dir
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "types" $ do
|
||||
it "shows types of the expression and its outers" $ do
|
||||
withDirectory_ "test/data/ghc-mod-check" $ do
|
||||
res <- runD $ types "Data/Foo.hs" 9 5
|
||||
let tdir = "test/data/ghc-mod-check"
|
||||
res <- runD' tdir $ types "lib/Data/Foo.hs" 9 5
|
||||
res `shouldBe` "9 5 11 40 \"Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n"
|
||||
|
||||
it "works with a module using TemplateHaskell" $ do
|
||||
withDirectory_ "test/data" $ do
|
||||
res <- runD $ types "Bar.hs" 5 1
|
||||
let tdir = "test/data/template-haskell"
|
||||
res <- runD' tdir $ types "Bar.hs" 5 1
|
||||
res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]
|
||||
|
||||
it "works with a module that imports another module using TemplateHaskell" $ do
|
||||
withDirectory_ "test/data" $ do
|
||||
res <- runD $ types "Main.hs" 3 8
|
||||
let tdir = "test/data/template-haskell"
|
||||
res <- runD' tdir $ types "ImportsTH.hs" 3 8
|
||||
res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""]
|
||||
|
||||
describe "info" $ do
|
||||
it "works for non-export functions" $ do
|
||||
withDirectory_ "test/data" $ do
|
||||
res <- runD $ info "Info.hs" "fib"
|
||||
it "works for non exported functions" $ do
|
||||
let tdir = "test/data/non-exported"
|
||||
res <- runD' tdir $ info "Fib.hs" $ Expression "fib"
|
||||
res `shouldSatisfy` ("fib :: Int -> Int" `isPrefixOf`)
|
||||
|
||||
it "works with a module using TemplateHaskell" $ do
|
||||
withDirectory_ "test/data" $ do
|
||||
res <- runD $ info "Bar.hs" "foo"
|
||||
let tdir = "test/data/template-haskell"
|
||||
res <- runD' tdir $ info "Bar.hs" $ Expression "foo"
|
||||
res `shouldSatisfy` ("foo :: ExpQ" `isPrefixOf`)
|
||||
|
||||
it "works with a module that imports another module using TemplateHaskell" $ do
|
||||
withDirectory_ "test/data" $ do
|
||||
res <- runD $ info "Main.hs" "bar"
|
||||
let tdir = "test/data/template-haskell"
|
||||
res <- runD' tdir $ info "ImportsTH.hs" $ Expression "bar"
|
||||
res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`)
|
||||
|
||||
it "doesn't fail on unicode output" $ do
|
||||
dir <- getDistDir
|
||||
code <- rawSystem (dir </> "build/ghc-mod/ghc-mod") ["info", "test/data/Unicode.hs", "Unicode", "unicode"]
|
||||
code `shouldSatisfy` (== ExitSuccess)
|
||||
|
||||
getDistDir :: IO FilePath
|
||||
getDistDir = takeDirectory . takeDirectory . takeDirectory <$> getExecutablePath
|
||||
|
@ -8,10 +8,10 @@ spec :: Spec
|
||||
spec = do
|
||||
describe "lint" $ do
|
||||
it "can detect a redundant import" $ do
|
||||
res <- runD $ lint "test/data/hlint.hs"
|
||||
res `shouldBe` "test/data/hlint.hs:4:8: Error: Redundant do\NULFound:\NUL do putStrLn \"Hello, world!\"\NULWhy not:\NUL putStrLn \"Hello, world!\"\n"
|
||||
res <- runD $ lint "test/data/hlint/hlint.hs"
|
||||
res `shouldBe` "test/data/hlint/hlint.hs:4:8: Error: Redundant do\NULFound:\NUL do putStrLn \"Hello, world!\"\NULWhy not:\NUL putStrLn \"Hello, world!\"\n"
|
||||
|
||||
context "when no suggestions are given" $ do
|
||||
it "doesn't output an empty line" $ do
|
||||
res <- runD $ lint "test/data/ghc-mod-check/Data/Foo.hs"
|
||||
res <- runD $ lint "test/data/ghc-mod-check/lib/Data/Foo.hs"
|
||||
res `shouldBe` ""
|
||||
|
25
test/Main.hs
25
test/Main.hs
@ -4,6 +4,7 @@ import Dir
|
||||
|
||||
import Control.Exception as E
|
||||
import Control.Monad (void)
|
||||
import Data.List
|
||||
import Language.Haskell.GhcMod (debugInfo)
|
||||
import System.Process
|
||||
import Test.Hspec
|
||||
@ -11,22 +12,38 @@ import TestUtils
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
let sandboxes = [ "test/data", "test/data/check-packageid"
|
||||
let sandboxes = [ "test/data/cabal-project"
|
||||
, "test/data/check-packageid"
|
||||
, "test/data/duplicate-pkgver/"
|
||||
, "test/data/broken-cabal/"
|
||||
]
|
||||
genSandboxCfg dir = withDirectory dir $ \cwdir -> do
|
||||
system ("sed 's|@CWD@|" ++ cwdir ++ "|g' cabal.sandbox.config.in > cabal.sandbox.config")
|
||||
pkgDirs =
|
||||
[ "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"
|
||||
[ "test/data/cabal-project/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"
|
||||
, "test/data/check-packageid/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"
|
||||
, "test/data/duplicate-pkgver/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"]
|
||||
genGhcPkgCache dir = system $ "ghc-pkg recache --force -f" ++ dir
|
||||
|
||||
genSandboxCfg `mapM_` sandboxes
|
||||
genGhcPkgCache `mapM_` pkgDirs
|
||||
void $ system "find test -name setup-config -name ghc-mod.cache -exec rm {} \\;"
|
||||
|
||||
let caches = [ "setup-config"
|
||||
, "setup-config.ghc-mod.cabal-helper"
|
||||
, "setup-config.ghc-mod.cabal-components"
|
||||
, "setup-config.ghc-mod.resolved-components"
|
||||
, "setup-config.ghc-mod.package-options"
|
||||
, "setup-config.ghc-mod.package-db-stack"
|
||||
, "ghc-mod.cache"
|
||||
]
|
||||
cachesFindExp :: String
|
||||
cachesFindExp = unwords $ intersperse "-o " $ map ("-name "++) caches
|
||||
|
||||
cleanCmd = "find test \\( "++ cachesFindExp ++" \\) -exec rm {} \\;"
|
||||
|
||||
putStrLn $ "$ " ++ cleanCmd
|
||||
void $ system cleanCmd
|
||||
void $ system "cabal --version"
|
||||
putStrLn $ "ghc-mod was built with Cabal version " ++ VERSION_Cabal
|
||||
void $ system "ghc --version"
|
||||
|
||||
(putStrLn =<< runD debugInfo)
|
||||
|
@ -1,39 +1,17 @@
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
module MonadSpec where
|
||||
|
||||
import Test.Hspec
|
||||
import Dir
|
||||
import TestUtils
|
||||
import Control.Applicative
|
||||
import Control.Exception
|
||||
import Control.Monad.Error.Class
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "When using GhcModT in a do block" $
|
||||
it "a pattern match failure causes a call to `fail` on ErrorT in the monad stack" $ do
|
||||
(a, _)
|
||||
(a, _h)
|
||||
<- runGhcModT defaultOptions $
|
||||
do
|
||||
Just _ <- return Nothing
|
||||
return "hello"
|
||||
`catchError` (const $ fail "oh noes")
|
||||
a `shouldBe` (Left $ GMEString "oh noes")
|
||||
|
||||
describe "runGhcModT" $
|
||||
it "complains if the cabal file fails to parse while a sandbox is present" $ withDirectory_ "test/data/broken-cabal" $ do
|
||||
shouldReturnError $ runD' (gmCradle <$> ask)
|
||||
|
||||
describe "gmsGet/Put" $
|
||||
it "work" $ do
|
||||
(runD $ gmsPut (GhcModState Intelligent) >> gmsGet)
|
||||
`shouldReturn` (GhcModState Intelligent)
|
||||
|
||||
describe "liftIO" $ do
|
||||
it "converts user errors to GhcModError" $ do
|
||||
shouldReturnError $
|
||||
runD' $ liftIO $ throw (userError "hello") >> return ""
|
||||
|
||||
it "converts a file not found exception to GhcModError" $ do
|
||||
shouldReturnError $
|
||||
runD' $ liftIO $ readFile "/DOES_NOT_EXIST" >> return ""
|
||||
|
@ -1,42 +1,33 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
module PathsAndFilesSpec where
|
||||
|
||||
import Language.Haskell.GhcMod.PathsAndFiles
|
||||
#if __GLASGOW_HASKELL__ <= 706
|
||||
import Language.Haskell.GhcMod.Types
|
||||
import Language.Haskell.GhcMod.GhcPkg
|
||||
#endif
|
||||
|
||||
import System.Directory
|
||||
import System.Environment
|
||||
import System.FilePath ((</>))
|
||||
import System.FilePath
|
||||
import Test.Hspec
|
||||
import TestUtils
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "getSandboxDb" $ do
|
||||
-- ghc < 7.8
|
||||
#if __GLASGOW_HASKELL__ <= 706
|
||||
it "does include a sandbox with ghc < 7.8" $ do
|
||||
cwd <- getCurrentDirectory
|
||||
getPackageDbStack "test/data/" `shouldReturn` [GlobalDb, PackageDb $ cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"]
|
||||
#endif
|
||||
|
||||
it "can parse a config file and extract the sandbox package-db" $ do
|
||||
cwd <- getCurrentDirectory
|
||||
pkgDb <- getSandboxDb "test/data/"
|
||||
pkgDb `shouldBe` Just (cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d")
|
||||
Just db <- getSandboxDb "test/data/cabal-project"
|
||||
db `shouldSatisfy` isPkgDbAt (cwd </> "test/data/cabal-project/.cabal-sandbox")
|
||||
|
||||
it "returns Nothing if the sandbox config file is broken" $ do
|
||||
getSandboxDb "test/data/broken-sandbox" `shouldReturn` Nothing
|
||||
|
||||
describe "getCabalFiles" $ do
|
||||
it "doesn't think $HOME/.cabal is a cabal file" $ do
|
||||
(getCabalFiles =<< getEnv "HOME") `shouldReturn` []
|
||||
|
||||
describe "findCabalFile" $ do
|
||||
it "works" $ do
|
||||
findCabalFile "test/data" `shouldReturn` Just "test/data/cabalapi.cabal"
|
||||
findCabalFile "test/data/cabal-project" `shouldReturn` Just "test/data/cabal-project/cabalapi.cabal"
|
||||
|
||||
it "finds cabal files in parent directories" $ do
|
||||
findCabalFile "test/data/subdir1/subdir2" `shouldReturn` Just "test/data/cabalapi.cabal"
|
||||
findCabalFile "test/data/cabal-project/subdir1/subdir2" `shouldReturn` Just "test/data/cabal-project/cabalapi.cabal"
|
||||
|
||||
describe "findCabalSandboxDir" $ do
|
||||
it "works" $ do
|
||||
findCabalSandboxDir "test/data/cabal-project" `shouldReturn` Just "test/data/cabal-project"
|
||||
|
||||
it "finds sandboxes in parent directories" $ do
|
||||
findCabalSandboxDir "test/data/cabal-project/subdir1/subdir2" `shouldReturn` Just "test/data/cabal-project"
|
||||
|
46
test/TargetSpec.hs
Normal file
46
test/TargetSpec.hs
Normal 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")
|
@ -1,26 +1,36 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module TestUtils (
|
||||
run
|
||||
, runD
|
||||
, runD'
|
||||
, runI
|
||||
, runID
|
||||
, runIsolatedGhcMod
|
||||
, isolateCradle
|
||||
, runE
|
||||
, runNullLog
|
||||
, shouldReturnError
|
||||
, isPkgDbAt
|
||||
, isPkgConfDAt
|
||||
, module Language.Haskell.GhcMod.Monad
|
||||
, module Language.Haskell.GhcMod.Types
|
||||
) where
|
||||
|
||||
import Language.Haskell.GhcMod.Logging
|
||||
import Language.Haskell.GhcMod.Monad
|
||||
import Language.Haskell.GhcMod.Cradle
|
||||
import Language.Haskell.GhcMod.Types
|
||||
|
||||
import Control.Arrow
|
||||
import Control.Applicative
|
||||
import Control.Monad.Error (ErrorT, runErrorT)
|
||||
import Control.Monad.Trans.Journal
|
||||
import Data.List.Split
|
||||
import Data.String
|
||||
import System.FilePath
|
||||
import System.Directory
|
||||
import Test.Hspec
|
||||
|
||||
isolateCradle :: IOish m => GhcModT m a -> GhcModT m a
|
||||
isolateCradle action =
|
||||
local modifyEnv $ action
|
||||
where
|
||||
modifyEnv e = e { gmCradle = (gmCradle e) { cradlePkgDbStack = [GlobalDb] } }
|
||||
import Exception
|
||||
|
||||
testLogLevel :: GmLogLevel
|
||||
testLogLevel = GmDebug
|
||||
|
||||
extract :: Show e => IO (Either e a, w) -> IO a
|
||||
extract action = do
|
||||
@ -29,28 +39,46 @@ extract action = do
|
||||
Right a -> return a
|
||||
Left e -> error $ show e
|
||||
|
||||
runIsolatedGhcMod :: Options -> GhcModT IO a -> IO a
|
||||
runIsolatedGhcMod opt action = do
|
||||
extract $ runGhcModT opt $ isolateCradle action
|
||||
withSpecCradle :: IOish m => FilePath -> (Cradle -> m a) -> m a
|
||||
withSpecCradle cradledir f =
|
||||
gbracket (liftIO $ findSpecCradle cradledir) (liftIO . cleanupCradle) f
|
||||
|
||||
-- | Run GhcMod in isolated cradle with default options
|
||||
runID :: GhcModT IO a -> IO a
|
||||
runID = runIsolatedGhcMod defaultOptions
|
||||
withGhcModEnvSpec :: IOish m => FilePath -> Options -> (GhcModEnv -> m a) -> m a
|
||||
withGhcModEnvSpec dir opt f = withSpecCradle dir $ withGhcModEnv' opt f
|
||||
|
||||
-- | Run GhcMod in isolated cradle
|
||||
runI :: Options -> GhcModT IO a -> IO a
|
||||
runI = runIsolatedGhcMod
|
||||
runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog)
|
||||
runGhcModTSpec opt action = do
|
||||
dir <- getCurrentDirectory
|
||||
runGhcModTSpec' dir opt action
|
||||
|
||||
runGhcModTSpec' :: IOish m
|
||||
=> FilePath -> Options -> GhcModT m b -> m (Either GhcModError b, GhcModLog)
|
||||
runGhcModTSpec' dir opt action = liftIO (canonicalizePath dir) >>= \dir' ->
|
||||
withGhcModEnvSpec dir' opt $ \env -> do
|
||||
first (fst <$>) <$> runGhcModT'' env defaultGhcModState
|
||||
(gmSetLogLevel (logLevel opt) >> action)
|
||||
|
||||
-- | Run GhcMod
|
||||
run :: Options -> GhcModT IO a -> IO a
|
||||
run opt a = extract $ runGhcModT opt a
|
||||
run opt a = extract $ runGhcModTSpec opt a
|
||||
|
||||
-- | Run GhcMod with default options
|
||||
runD :: GhcModT IO a -> IO a
|
||||
runD = extract . runGhcModT defaultOptions
|
||||
runD =
|
||||
extract . runGhcModTSpec defaultOptions { logLevel = testLogLevel }
|
||||
|
||||
runD' :: GhcModT IO a -> IO (Either GhcModError a, GhcModLog)
|
||||
runD' = runGhcModT defaultOptions
|
||||
runD' :: FilePath -> GhcModT IO a -> IO a
|
||||
runD' dir =
|
||||
extract . runGhcModTSpec' dir defaultOptions { logLevel = testLogLevel }
|
||||
|
||||
runE :: ErrorT e IO a -> IO (Either e a)
|
||||
runE = runErrorT
|
||||
|
||||
runNullLog :: MonadIO m => JournalT GhcModLog m a -> m a
|
||||
runNullLog action = do
|
||||
(a,w) <- runJournalT action
|
||||
liftIO $ print w
|
||||
return a
|
||||
|
||||
shouldReturnError :: Show a
|
||||
=> IO (Either GhcModError a, GhcModLog)
|
||||
@ -61,3 +89,21 @@ shouldReturnError action = do
|
||||
where
|
||||
isLeft (Left _) = True
|
||||
isLeft _ = False
|
||||
|
||||
isPkgConfD :: FilePath -> Bool
|
||||
isPkgConfD d = let
|
||||
(_dir, pkgconfd) = splitFileName d
|
||||
in case splitOn "-" pkgconfd of
|
||||
[_arch, _platform, _compiler, _compver, "packages.conf.d"] -> True
|
||||
_ -> False
|
||||
|
||||
isPkgConfDAt :: FilePath -> FilePath -> Bool
|
||||
isPkgConfDAt d d' | d == takeDirectory d' && isPkgConfD d' = True
|
||||
isPkgConfDAt _ _ = False
|
||||
|
||||
isPkgDbAt :: FilePath -> GhcPkgDb -> Bool
|
||||
isPkgDbAt d (PackageDb dir) = isPkgConfDAt d dir
|
||||
isPkgDbAt _ _ = False
|
||||
|
||||
instance IsString ModuleName where
|
||||
fromString = mkModuleName
|
||||
|
@ -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 ""
|
@ -1,4 +0,0 @@
|
||||
module Unicode where
|
||||
|
||||
unicode :: α -> α
|
||||
unicode = id
|
6
test/data/annotations/With.hs
Normal file
6
test/data/annotations/With.hs
Normal file
@ -0,0 +1,6 @@
|
||||
module Main where
|
||||
|
||||
{-# ANN module ["this", "can", "be", "anything"] #-}
|
||||
|
||||
main :: IO ()
|
||||
main = putStrLn "Hello world!"
|
@ -1 +0,0 @@
|
||||
broken
|
@ -7,8 +7,7 @@ flag test-flag
|
||||
default: False
|
||||
|
||||
library
|
||||
build-depends: base == 4.*
|
||||
build-depends: base
|
||||
|
||||
if flag(test-flag)
|
||||
build-depends: Cabal >= 1.10
|
||||
|
||||
|
4
test/data/cabal-preprocessors/Main.hs
Normal file
4
test/data/cabal-preprocessors/Main.hs
Normal file
@ -0,0 +1,4 @@
|
||||
import Preprocessed
|
||||
|
||||
main :: IO ()
|
||||
main = return warning
|
3
test/data/cabal-preprocessors/Preprocessed.hsc
Normal file
3
test/data/cabal-preprocessors/Preprocessed.hsc
Normal file
@ -0,0 +1,3 @@
|
||||
module Preprocessed where
|
||||
|
||||
warning = ()
|
14
test/data/cabal-preprocessors/cabal-preprocessors.cabal
Normal file
14
test/data/cabal-preprocessors/cabal-preprocessors.cabal
Normal 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
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user