aboutsummaryrefslogtreecommitdiff
path: root/haddock-api
diff options
context:
space:
mode:
Diffstat (limited to 'haddock-api')
-rw-r--r--haddock-api/COPYING.agpl3661
-rw-r--r--haddock-api/COPYING.freebsd (renamed from haddock-api/LICENSE)0
-rw-r--r--haddock-api/haddorg-api.cabal (renamed from haddock-api/haddock-api.cabal)33
-rw-r--r--haddock-api/src/Haddock.hs10
-rw-r--r--haddock-api/src/Haddock/Backends/Org.hs1072
-rw-r--r--haddock-api/src/Haddock/Backends/Org/Types.hs260
-rw-r--r--haddock-api/src/Haddock/Options.hs549
-rw-r--r--haddock-api/src/Haddock/Version.hs2
8 files changed, 2349 insertions, 238 deletions
diff --git a/haddock-api/COPYING.agpl3 b/haddock-api/COPYING.agpl3
new file mode 100644
index 00000000..be3f7b28
--- /dev/null
+++ b/haddock-api/COPYING.agpl3
@@ -0,0 +1,661 @@
+ GNU AFFERO GENERAL PUBLIC LICENSE
+ Version 3, 19 November 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc. <https://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 <https://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
+<https://www.gnu.org/licenses/>.
diff --git a/haddock-api/LICENSE b/haddock-api/COPYING.freebsd
index d5f0b37c..d5f0b37c 100644
--- a/haddock-api/LICENSE
+++ b/haddock-api/COPYING.freebsd
diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddorg-api.cabal
index 5923ba37..85a68131 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddorg-api.cabal
@@ -1,16 +1,14 @@
cabal-version: 3.0
-name: haddock-api
+name: haddorg-api
version: 2.27.0
-synopsis: A documentation-generation tool for Haskell libraries
-description: Haddock is a documentation-generation tool for Haskell
- libraries
-license: BSD-2-Clause
-license-file: LICENSE
-author: Simon Marlow, David Waern
-maintainer: Alec Theriault <alec.theriault@gmail.com>, Alex Biehl <alexbiehl@gmail.com>, Simon Hengel <sol@typeful.net>, Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>
-homepage: http://www.haskell.org/haddock/
-bug-reports: https://github.com/haskell/haddock/issues
-copyright: (c) Simon Marlow, David Waern
+synopsis: haddock-api with an org backend
+description: This is haddorg-api. It is a modified version of the Haddock API (haddock-api) with the addition of an Org Backend. See README.org for further information.
+license: BSD-2-Clause AND AGPL-3.0-or-later
+license-files: COPYING.freebsd, COPYING.agpl3
+author: Haddock authors and Yuchen Pei
+maintainer: Yuchen Pei <id@ypei.org>
+homepage: https://g.ypei.me/haddorg.git
+copyright: Copyright holders of haddock-api, and Yuchen Pei
category: Documentation
build-type: Simple
tested-with: GHC==9.4.*
@@ -63,6 +61,7 @@ library
, ghc-boot
, mtl
, transformers
+ , text
hs-source-dirs: src
@@ -113,6 +112,8 @@ library
Haddock.Backends.Hyperlinker.Renderer
Haddock.Backends.Hyperlinker.Types
Haddock.Backends.Hyperlinker.Utils
+ Haddock.Backends.Org
+ Haddock.Backends.Org.Types
Haddock.ModuleTree
Haddock.Types
Haddock.Doc
@@ -122,10 +123,10 @@ library
Haddock.GhcUtils
Haddock.Syb
Haddock.Convert
- Paths_haddock_api
+ Paths_haddorg_api
autogen-modules:
- Paths_haddock_api
+ Paths_haddorg_api
test-suite spec
type: exitcode-stdio-1.0
@@ -144,6 +145,8 @@ test-suite spec
Haddock.Backends.Hyperlinker.Renderer
Haddock.Backends.Hyperlinker.Utils
Haddock.Backends.LaTeX
+ Haddock.Backends.Org
+ Haddock.Backends.Org.Types
Haddock.Backends.Xhtml
Haddock.Backends.Xhtml.Decl
Haddock.Backends.Xhtml.DocMarkup
@@ -175,7 +178,7 @@ test-suite spec
Haddock.Utils.Json.Types
Haddock.Utils.Json.Parser
Haddock.Version
- Paths_haddock_api
+ Paths_haddorg_api
Haddock.Backends.Hyperlinker.ParserSpec
Haddock.Backends.Hyperlinker.Parser
Haddock.Backends.Hyperlinker.Types
@@ -210,4 +213,4 @@ test-suite spec
source-repository head
type: git
subdir: haddock-api
- location: https://github.com/haskell/haddock.git
+ location: https://g.ypei.me/haddock.git
diff --git a/haddock-api/src/Haddock.hs b/haddock-api/src/Haddock.hs
index ea664bcf..f4bc355e 100644
--- a/haddock-api/src/Haddock.hs
+++ b/haddock-api/src/Haddock.hs
@@ -36,6 +36,7 @@ import Haddock.Backends.Xhtml.Themes (getThemes)
import Haddock.Backends.LaTeX
import Haddock.Backends.Hoogle
import Haddock.Backends.Hyperlinker
+import Haddock.Backends.Org
import Haddock.Interface
import Haddock.Interface.Json
import Haddock.Parser
@@ -66,7 +67,7 @@ import System.FilePath
import System.Environment (getExecutablePath)
#else
import qualified GHC.Paths as GhcPaths
-import Paths_haddock_api (getDataDir)
+import Paths_haddorg_api (getDataDir)
#endif
import System.Directory (doesDirectoryExist, getTemporaryDirectory)
@@ -221,7 +222,7 @@ haddockWithGhc ghc args = handleTopExceptions $ do
liftIO $ renderStep logger dflags unit_state flags sinceQual qual packages ifaces
else do
- when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $
+ when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX, Flag_Org]) flags) $
throwE "No input file(s)."
-- Get packages supplied with --read-interface.
@@ -510,6 +511,11 @@ render log' dflags unit_state flags sinceQual qual ifaces packages extSrcMap = d
ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style
libDir
return ()
+ when (Flag_Org `elem` flags) $ do
+ withTiming logger dflags' "ppOrg" (const ()) $ do
+ _ <- {-# SCC ppOrg #-}
+ ppOrg title pkgStr odir (_doc <$> prologue) visibleIfaces
+ return ()
when (Flag_HyperlinkedSource `elem` flags && not (null ifaces)) $ do
withTiming logger "ppHyperlinkedSource" (const ()) $ do
diff --git a/haddock-api/src/Haddock/Backends/Org.hs b/haddock-api/src/Haddock/Backends/Org.hs
new file mode 100644
index 00000000..76924210
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Org.hs
@@ -0,0 +1,1072 @@
+{-
+Copyright (C) 2022 Yuchen Pei.
+
+This file is part of haddorg-api.
+
+This file 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 file 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 file. If not, see
+<https://www.gnu.org/licenses/>.
+-}
+
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TupleSections #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Haddock.Backends.Org
+ ( ppOrg
+ ) where
+import Control.Monad.State.Strict ( State
+ , evalState
+ , get
+ , put
+ )
+import Data.List ( intercalate
+ , intersperse
+ , isSuffixOf
+ , singleton
+ , sortOn
+ )
+import Data.Map ( (!?)
+ , toList
+ )
+import qualified Data.Map as M
+ ( empty
+ , map
+ , null
+ )
+import Data.Maybe ( fromMaybe )
+import Documentation.Haddock.Markup ( markup
+ , plainMarkup
+ )
+import GHC ( ConDecl(..)
+ , ConDeclField(..)
+ , FamEqn(..)
+ , FamilyDecl(..)
+ , FamilyInfo(..)
+ , FamilyResultSig(..)
+ , FieldOcc(..)
+ , ForeignDecl(..)
+ , GenLocated(..)
+ , HsArg(..)
+ , HsConDeclGADTDetails(..)
+ , HsConDeclH98Details
+ , HsConDetails(..)
+ , HsDataDefn(..)
+ , HsDecl(..)
+ , HsForAllTelescope(..)
+ , HsOuterSigTyVarBndrs
+ , HsOuterTyVarBndrs(..)
+ , HsScaled(..)
+ , HsSigType(..)
+ , HsTupleSort(..)
+ , HsTyLit(..)
+ , HsTyVarBndr(..)
+ , HsType(..)
+ , InjectivityAnn(..)
+ , LHsContext
+ , LHsKind
+ , LHsQTyVars(..)
+ , LHsTyVarBndr
+ , LHsType
+ , LInjectivityAnn
+ , LTyFamInstEqn
+ , ModuleName
+ , Name
+ , NewOrData(..)
+ , RdrName
+ , Sig(..)
+ , TyClDecl(..)
+ , dropWildCards
+ , getName
+ , hsIPNameFS
+ , hsQTvExplicit
+ , moduleNameString
+ , unLoc
+ )
+import GHC.Data.FastString ( unpackFS )
+import GHC.Types.Basic ( PromotionFlag(..)
+ , TopLevelFlag(..)
+ )
+import GHC.Types.Name ( isDataConName
+ , nameModule_maybe
+ , nameOccName
+ )
+import GHC.Types.Name.Occurrence ( OccName
+ , occNameString
+ )
+import GHC.Unit.Types ( GenModule(..)
+ , Module
+ , unitString
+ )
+import GHC.Utils.Outputable ( showPprUnsafe )
+import qualified GHC.Utils.Ppr as Pretty
+import GHC.Utils.Ppr ( (<+>)
+ , (<>)
+ , comma
+ , hsep
+ , punctuate
+ , text
+ )
+import Haddock.Backends.Org.Types
+import Haddock.GhcUtils ( Precedence(..)
+ , hsLTyVarNameI
+ , moduleString
+ , reparenTypePrec
+ )
+import Haddock.Types ( Doc
+ , DocForDecl
+ , DocH(..)
+ , DocInstance
+ , DocName(..)
+ , DocNameI
+ , Documentation(..)
+ , ExportItem(..)
+ , FnArgsDoc
+ , Header(..)
+ , Hyperlink(..)
+ , InstHead(..)
+ , InstType(..)
+ , Interface(..)
+ , MDoc
+ , MetaDoc(..)
+ , ModLink(..)
+ , Picture(..)
+ , TableCell(..)
+ , TableRow(..)
+ , Wrap(..)
+ , showWrapped
+ )
+import qualified Haddock.Types as HT
+ ( Example(..)
+ , Table(..)
+ )
+import Haddock.Utils ( writeUtf8File )
+import Prelude hiding ( (<>) )
+import System.Directory
+import System.FilePath
+
+
+type PDoc = Pretty.Doc
+type ModPath = (String, String) -- (package, module)
+type SubDocs = [(DocName, DocForDecl DocName)]
+
+packageLevel, modLevel :: Int
+packageLevel = 1
+modLevel = 2
+
+-- prefix for unimplemented and error
+unimp, docError :: String -> String
+unimp = ("UNIMP$" ++)
+docError = ("ERROR$" ++)
+
+unimpHeading :: String -> Int -> OrgBlock
+unimpHeading thing level = headingPlainText (unimp thing) level
+
+emptyDoc :: DocForDecl DocName
+emptyDoc = (Documentation Nothing Nothing, M.empty)
+
+-- The main function
+ppOrg
+ :: String
+ -> Maybe String
+ -> FilePath
+ -> Maybe (Doc RdrName)
+ -> [Interface]
+ -> IO ()
+ppOrg title pkgStr odir mbPrologue ifaces =
+ let org = orgToString $ fromOrgDocument $ toOrgDocument
+ title
+ mbPrologue
+ (fromMaybe "" (cleanPkgStr <$> pkgStr))
+ ifaces
+ in createDirectoryIfMissing True odir
+ >> writeUtf8File
+ (odir </> (fromMaybe "haddock" (cleanPkgStr <$> pkgStr) <.> "org"))
+ org
+
+toOrgDocument
+ :: String -> Maybe (Doc RdrName) -> String -> [Interface] -> OrgDocument
+toOrgDocument title mbPrologue pkgId ifaces =
+ OrgDocument M.empty (processPackage title mbPrologue pkgId ifaces)
+
+processPackage
+ :: String -> Maybe (Doc RdrName) -> String -> [Interface] -> [OrgBlock]
+processPackage title mbPrologue pkgId ifaces =
+ Heading packageLevel
+ [plaintext title]
+ (cIdProp pkgId ++ hackageProp (hackagePackageUrl pkgId))
+ : Paragraph [plaintext $ maybe [] removeMarkup' mbPrologue]
+ : concatMap processModule (sortOn ifaceMod ifaces)
+
+processModule :: Interface -> [OrgBlock]
+processModule iface =
+ let
+ mdl = moduleString $ ifaceMod iface
+ pkg = cleanPkgStr $ unitString $ moduleUnit $ ifaceMod iface
+ path = (pkg, mdl)
+ heading = Heading
+ modLevel
+ [plaintext mdl]
+ (cIdProp (pkg ++ "." ++ mdl) ++ hackageProp (hackageModuleUrl pkg mdl))
+ description = ppDocumentation (ifaceRnDoc iface) (Just modLevel)
+ exported =
+ evalState (mapM (processExport path) (ifaceRnExportItems iface)) modLevel
+ ++ [ ppDocInsts
+ (ifaceRnOrphanInstances iface)
+ "Orphan Instances"
+ (modLevel + 1)
+ ]
+ in
+ heading : description ++ concat exported
+
+processExport :: ModPath -> ExportItem DocNameI -> State Int [OrgBlock]
+-- TODO: handle bundled patterns, fixities and splice
+processExport path (ExportDecl (L _ decl) _pats docs subdocs insts _fixities _splice)
+ = do
+ baseLevel <- get
+ return $ ppHsDecl decl insts docs subdocs path (baseLevel + 1)
+processExport _ (ExportNoDecl _ _ ) = error "ExportNoDecl"
+processExport _ (ExportGroup offset _ label) = do
+ put $ modLevel + offset
+ return $ ppDocBlock (DocHeader (Header (modLevel + offset) label)) (Just 0)
+processExport _ (ExportDoc mDoc) = return $ ppMDoc mDoc (Just modLevel)
+processExport _ (ExportModule mdl ) = do
+ baseLevel <- get
+ return
+ [ Heading
+ (baseLevel + 1)
+ [plaintext "module", Whitespace, Link (text (moduleString mdl)) []]
+ []
+ ]
+
+-- * To Org elements
+-- ** Documentation to Org elements
+
+ppFnArgsDoc :: FnArgsDoc DocName -> [OrgBlock]
+ppFnArgsDoc aDoc = if M.null aDoc
+ then []
+ else ((`ppDoc` Nothing) . DocParagraph . DocString) "Arguments (in order):"
+ ++ ((`ppDoc` Nothing) . DocOrderedList . toList . M.map _doc) aDoc
+
+ppDocumentation :: Documentation DocName -> Maybe Int -> [OrgBlock]
+ppDocumentation (Documentation (Just mdoc) _) minLevel = ppMDoc mdoc minLevel
+ppDocumentation _ _ = []
+
+ppMDoc :: MDoc DocName -> Maybe Int -> [OrgBlock]
+ppMDoc (MetaDoc _ doc) = ppDoc doc
+
+ppDoc :: Doc DocName -> Maybe Int -> [OrgBlock]
+ppDoc x l = if isBlock x then ppDocBlock x l else [Paragraph $ ppDocInline x]
+
+ppDocBlock :: Doc DocName -> Maybe Int -> [OrgBlock]
+ppDocBlock x _ | not (isBlock x) = ppDocBlock (DocParagraph x) Nothing
+ppDocBlock DocEmpty _ = []
+ppDocBlock (DocAppend x y ) l = ppDocBlock x l ++ ppDocBlock y l
+ppDocBlock (DocParagraph x) _ = [Paragraph (ppDocInline x)]
+ppDocBlock (DocUnorderedList docs) _ =
+ [PlainList Unordered $ (`ppDocBlock` Nothing) <$> docs]
+ppDocBlock (DocOrderedList items) _ =
+ [PlainList Ordered (map ((`ppDocBlock` Nothing) . snd) items)]
+ppDocBlock (DocDefList pairs) _ =
+ [ DefList
+ $ (\(term, def) -> (ppDocInline term, ppDocBlock def Nothing))
+ <$> pairs
+ ]
+ppDocBlock (DocCodeBlock doc) _ =
+ [SrcBlock $ text $ fixLeadingStar $ removeMarkup doc]
+ppDocBlock (DocMathDisplay x) _ = [MathDisplay (text x)]
+ppDocBlock (DocExamples examples) _ =
+ (\(HT.Example expr res) -> Example
+ (text (fixLeadingStar expr))
+ (text $ fixLeadingStar $ intercalate "\n" res)
+ )
+ <$> examples
+ppDocBlock (DocHeader (Header level label)) (Just l) =
+ [Heading (level + l) (ppDocInline label) []]
+ppDocBlock (DocTable (HT.Table hRows bRows)) _ = ppTable hRows bRows
+ppDocBlock doc _ = [Paragraph [plaintext $ unimp "ppDocBlock: " ++ show doc]]
+
+ppDocInline :: Doc DocName -> [OrgInline]
+ppDocInline x | isBlock x = [plaintext $ docError "BLOCK_IN_INLINE" ++ show x]
+ppDocInline (DocAppend x y ) = ppDocInline x ++ ppDocInline y
+ppDocInline (DocString x) = [plaintext x]
+ppDocInline (DocIdentifier x) = ppWrapped ppDocName x
+ppDocInline (DocIdentifierUnchecked x) = ppWrapped ppMO x
+ppDocInline (DocModule (ModLink modName mbModLabel)) =
+ [Link (text modName) (maybe [] ppDocInline mbModLabel)]
+ppDocInline (DocWarning x) = [plaintext $ unimp $ "DocWarning: " ++ show x]
+ppDocInline (DocEmphasis x) = [Italic $ ppDocInline x]
+ppDocInline (DocMonospaced x) = [Code $ text $ removeMarkup x]
+ppDocInline (DocBold x) = [Bold $ ppDocInline x]
+ppDocInline (DocHyperlink (Hyperlink url label)) =
+ [Link (text url) (maybe [] ppDocInline label)]
+ppDocInline (DocPic (Picture url mbTitle)) =
+ [Link (text url) (maybe [] (singleton . plaintext) mbTitle)]
+ppDocInline (DocAName x) = [Anchor (text x)]
+ppDocInline (DocMathInline x) = [MathInline (text x)]
+ppDocInline (DocProperty x) = [plaintext x]
+ppDocInline doc = [plaintext $ unimp "ppDocInline: " ++ show doc]
+
+-- *** Handling tables
+-- current coordinates, colspan and rowspan coordinates
+type SpanState = ((Int, Int), [(Int, Int)], [(Int, Int)])
+
+emptySpanState :: SpanState
+emptySpanState = ((0, 0), [], [])
+
+-- marks for cells connected with colspan and rowspan
+leftSym, upSym :: Bool -> String
+leftSym True = "<"
+leftSym False = ""
+upSym True = "^"
+upSym False = ""
+
+ppTable :: [TableRow (Doc DocName)] -> [TableRow (Doc DocName)] -> [OrgBlock]
+ppTable header body =
+ [ Table (evalState (ppTable' header) emptySpanState)
+ (evalState (ppTable' body) emptySpanState)
+ ]
+
+ppTable' :: [TableRow (Doc DocName)] -> State SpanState [[[OrgInline]]]
+ppTable' [] = return []
+ppTable' (TableRow cells : rest) = do
+ cur <- ppTableRow' cells
+ rest' <- ppTable' rest
+ return $ cur : rest'
+
+-- handle a table row, tracking colspans and rowspans
+ppTableRow' :: [TableCell (Doc DocName)] -> State SpanState [[OrgInline]]
+ppTableRow' [] = return []
+ppTableRow' (TableCell colspan rowspan doc : rest) = do
+ ((x, y), colspans, rowspans) <- get
+ let
+ left = (not . null) colspans && (x, y) `elem` colspans
+ up = (not . null) rowspans && (x, y) `elem` rowspans
+ content = if left || up
+ then [plaintext (leftSym left ++ upSym up)]
+ else ppDocInline doc
+ newColspans = if left
+ then colspans
+ else colspans ++ map (\i -> (x, y + i)) [1 .. colspan - 1]
+ newRowspans = if up
+ then rowspans
+ else rowspans ++ map (\i -> (x + i, y)) [1 .. rowspan - 1]
+ extraLeft = if null rest
+ then length (takeWhile (`elem` newColspans) (map (x, ) [y + 1 ..]))
+ else 0
+ extraUp = if null rest
+ then length (takeWhile (`elem` newRowspans) (map (x, ) [y + 1 ..]))
+ else 0
+ n = max extraLeft extraUp
+ lefts = replicate extraLeft True ++ replicate (n - extraLeft) False
+ ups = replicate extraUp True ++ replicate (n - extraUp) False
+ extra = zipWith (\l u -> [plaintext (leftSym l ++ upSym u)]) lefts ups
+ newCoord = if null rest then (x + 1, 0) else (x, y + 1)
+ put (newCoord, newColspans, newRowspans)
+ rest' <- ppTableRow' rest
+ return $ content : extra ++ rest'
+
+-- ** AST to Org elements
+
+ppHsDecl
+ :: HsDecl DocNameI
+ -> [DocInstance DocNameI]
+ -> DocForDecl DocName
+ -> SubDocs
+ -> ModPath
+ -> Int
+ -> [OrgBlock]
+ppHsDecl (TyClD _ decl) insts docs subdocs path level =
+ ppTyClDecl decl docs subdocs path level
+ ++ ppDocInsts insts "Instances:" (level + 1)
+ppHsDecl (SigD _ sig) _ docs subdocs path level =
+ ppSig sig docs subdocs path level
+ppHsDecl (ForD _ for) _ docs _ path level = ppForeignDecl for docs path level
+ppHsDecl _ _ docs _ _ level =
+ unimpHeading "HsDecl" level : ppDocForDecl docs (Just level)
+
+ppForeignDecl
+ :: ForeignDecl DocNameI -> DocForDecl DocName -> ModPath -> Int -> [OrgBlock]
+ppForeignDecl (ForeignImport _ (L _ name) (L _ sigType) _) docs path level =
+ Heading level
+ (Plain (docNameToDoc name) : plaintext " :: " : ppHsSigType sigType)
+ (cIdPaths path name)
+ : ppDocForDecl docs (Just level)
+ppForeignDecl _ docs _ level =
+ unimpHeading "ForeignDecl" level : ppDocForDecl docs (Just level)
+
+ppDocInsts :: [DocInstance DocNameI] -> String -> Int -> [OrgBlock]
+ppDocInsts [] _ _ = []
+ppDocInsts insts heading level =
+ [headingPlainText heading level, PlainList Unordered (map ppDocInst insts)]
+
+ppDocInst :: DocInstance DocNameI -> [OrgBlock]
+ppDocInst (InstHead clsName types (ClassInst {..}), mbMdoc, _docName, _mbMod) =
+ prependInlinesToBlocks
+ ( interNotNull
+ [Whitespace]
+ [ ppContext clsiCtx
+ , ppDocName clsName
+ , intercalate [Whitespace]
+ (map (ppHsType . reparenTypePrec PREC_CON) types)
+ ]
+ ++ if mbMDocHasDoc mbMdoc
+ then
+ [Whitespace, plaintext "::", Whitespace]
+ else
+ []
+ )
+ (maybe [] (`ppMDoc` Nothing) mbMdoc)
+ppDocInst (InstHead clsName types (TypeInst mbRhs), mbMdoc, _docName, _mbMod) =
+ prependInlinesToBlocks
+ ( plaintext "type "
+ : ppDocName clsName
+ ++ [Whitespace]
+ ++ intercalate [Whitespace]
+ (map (ppHsType . reparenTypePrec PREC_CON) types)
+ ++ maybe
+ []
+ (\ty -> plaintext " = " : ppHsType (reparenTypePrec PREC_TOP ty))
+ mbRhs
+ ++ if mbMDocHasDoc mbMdoc
+ then [Whitespace, plaintext "::", Whitespace]
+ else []
+ )
+ (maybe [] (`ppMDoc` Nothing) mbMdoc)
+-- TODO: add decl
+ppDocInst (InstHead clsName types (DataInst _decl), mbMdoc, _docName, _mbMod) =
+ prependInlinesToBlocks
+ ( plaintext "data "
+ : ppDocName clsName
+ ++ [Whitespace]
+ ++ intercalate [Whitespace]
+ (map (ppHsType . reparenTypePrec PREC_CON) types)
+ ++ if mbMDocHasDoc mbMdoc
+ then [Whitespace, plaintext "::", Whitespace]
+ else []
+ )
+ (maybe [] (`ppMDoc` Nothing) mbMdoc)
+
+mbMDocHasDoc :: Maybe (MDoc DocName) -> Bool
+mbMDocHasDoc Nothing = False
+mbMDocHasDoc (Just (MetaDoc _ DocEmpty)) = False
+mbMDocHasDoc _ = True
+
+parensIfMany :: [a] -> [OrgInline] -> [OrgInline]
+parensIfMany xs org = if length xs > 1 then orgParens org else org
+
+dcSuffix :: DocName -> String
+dcSuffix name = if isDataConName (getName name) then ":dc" else ""
+
+idPath :: ModPath -> DocName -> String
+idPath (pkg, mdl) name =
+ pkg ++ "." ++ mdl ++ "." ++ docNameToString name ++ dcSuffix name
+
+idPath' :: Module -> DocName -> String
+idPath' mdl name =
+ idPath (cleanPkgStr $ unitString $ moduleUnit mdl, moduleString mdl) name
+
+idPathNoPkg :: String -> DocName -> String
+idPathNoPkg mdl name = mdl ++ "." ++ docNameToString name ++ dcSuffix name
+
+cIdPaths :: ModPath -> DocName -> Properties
+cIdPaths path@(_, mdl) name = cIdsProp [idPath path name, idPathNoPkg mdl name]
+
+ppTyClDecl
+ :: TyClDecl DocNameI
+ -> DocForDecl DocName
+ -> SubDocs
+ -> ModPath
+ -> Int
+ -> [OrgBlock]
+-- data T a b
+-- newtype T a b
+-- TODO: handle fixity
+ppTyClDecl (DataDecl _ (L _ name) tcdTyVars _ defn@(HsDataDefn { dd_ND = nd, dd_cons = cons })) docs subdocs path level
+ = [ Heading
+ level
+ ( Plain
+ ((ppNewOrData nd) <+> (docNameToDoc name) <+> hsep
+ (ppName <$> tyvarNames tcdTyVars)
+ )
+ : if gadt then [plaintext " where"] else []
+ )
+ (cIdPaths path name)
+ ]
+ ++ ppDocForDecl docs (Just level)
+ ++ ppDataDefn defn subdocs path (level + 1)
+ where
+ gadt = case cons of
+ [] -> False
+ L _ ConDeclGADT{} : _ -> True
+ _ -> False
+ppTyClDecl (DataDecl{}) docs _ _ level =
+ unimpHeading "DataDecl" level : ppDocForDecl docs (Just level)
+-- type T a b
+ppTyClDecl (SynDecl _ (L _ name) tcdTyVars _fixity (L _ rhs)) docs _ path level
+ = [ Heading
+ level
+ ( intersperse
+ Whitespace
+ ( [plaintext "type", Plain $ docNameToDoc name]
+ ++ map (Plain . ppName) (tyvarNames tcdTyVars)
+ ++ [Plain $ text "= "]
+ )
+ ++ ppHsType rhs
+ )
+ (cIdPaths path name)
+ ]
+ ++ ppDocForDecl docs (Just level)
+-- class
+ppTyClDecl (ClassDecl {..}) docs subdocs path level =
+ [ Heading
+ level
+ (interNotNull
+ [Whitespace]
+ [ [plaintext "class"]
+ , ppMbLHsContext tcdCtxt
+ , (singleton . Plain . docNameToDoc . unLoc) tcdLName
+ , intersperse Whitespace (map (Plain . ppName) (tyvarNames tcdTyVars))
+ ]
+ )
+ (cIdPaths path (unLoc tcdLName))
+ ]
+ ++ ppDocForDecl docs (Just level)
+ -- TODO: do we need an aDoc here instead of M.empty?
+ -- TODO: handle default sigs
+ ++ concatMap
+ ((\assoc -> ppFamilyDecl assoc False emptyDoc subdocs path (level + 1))
+ . unLoc
+ )
+ tcdATs
+ ++ concatMap
+ ((\sig -> ppSig sig emptyDoc subdocs path (level + 1)) . unLoc)
+ tcdSigs
+-- type family ... where
+-- TODO: handle infix
+ppTyClDecl (FamDecl _ familyDecl) docs subdocs path level =
+ ppFamilyDecl familyDecl True docs subdocs path level
+
+ppFamilyDecl
+ :: FamilyDecl DocNameI
+ -> Bool
+ -> DocForDecl DocName
+ -> SubDocs
+ -> ModPath
+ -> Int
+ -> [OrgBlock]
+ppFamilyDecl (FamilyDecl _ info@(ClosedTypeFamily mbEqns) TopLevel (L _ name) tyvars _fixity (L _ resSig) mbInj) isFamDecl docs subdocs path level
+ = Heading
+ level
+ ( ppFamilyInfo info isFamDecl
+ ++ [Whitespace, Plain $ docNameToDoc name, Whitespace]
+ ++ ppLHsQTyVars tyvars
+ ++ ppFamilyResultSig resSig
+ ++ maybe [] ppLInjectivityAnn mbInj
+ ++ [plaintext " where"]
+ )
+ (cIdPaths path name)
+ : (if isFamDecl
+ then ppDocForDecl docs (Just level)
+ else maybe [] (`ppDocForDecl` (Just level)) (lookup name subdocs)
+ )
+ ++ concatMap (\x -> ppLTyFamInstEqn x subdocs path (level + 1))
+ (fromMaybe [] mbEqns)
+ppFamilyDecl (FamilyDecl _ info TopLevel (L _ name) tyvars _fixity (L _ resSig) mbInj) isFamDecl docs subdocs path level
+ = Heading
+ level
+ ( ppFamilyInfo info isFamDecl
+ ++ [Whitespace, Plain $ docNameToDoc name, Whitespace]
+ ++ ppLHsQTyVars tyvars
+ ++ ppFamilyResultSig resSig
+ ++ maybe [] ppLInjectivityAnn mbInj
+ )
+ (cIdPaths path name)
+ : (if isFamDecl
+ then ppDocForDecl docs (Just level)
+ else maybe [] (`ppDocForDecl` (Just level)) (lookup name subdocs)
+ )
+ppFamilyDecl _ _ docs _ _ level =
+ unimpHeading "FamilyDecl" level : ppDocForDecl docs (Just level)
+
+ppFamilyInfo :: FamilyInfo DocNameI -> Bool -> [OrgInline]
+ppFamilyInfo info isFamDecl = dataOrType : family
+ where
+ dataOrType = case info of
+ DataFamily -> plaintext "data"
+ _ -> plaintext "type"
+ family = if isFamDecl then [plaintext " family"] else []
+
+ppLTyFamInstEqn
+ :: LTyFamInstEqn DocNameI -> SubDocs -> ModPath -> Int -> [OrgBlock]
+ppLTyFamInstEqn (L _ (FamEqn _ (L _ name) _ tyPats _fixity rhs)) subdocs _ level
+ = Heading
+ level
+ (interNotNull
+ [Whitespace]
+ [ ppDocName name
+ , intercalate [Whitespace] (map ppHsArg tyPats)
+ , [plaintext "="]
+ , ppLHsType (reparenTypePrec PREC_TOP <$> rhs)
+ ]
+ )
+ []
+ : maybe [] (`ppDocForDecl` (Just level)) (lookup name subdocs)
+
+ppHsArg :: HsArg (LHsType DocNameI) (LHsKind DocNameI) -> [OrgInline]
+ppHsArg (HsValArg ty) = ppLHsType (reparenTypePrec PREC_CON <$> ty)
+ppHsArg _ = [plaintext $ unimp "HsArg"]
+
+ppLInjectivityAnn :: LInjectivityAnn DocNameI -> [OrgInline]
+ppLInjectivityAnn (L _ (InjectivityAnn _ (L _ l) rs)) =
+ [ plaintext " | "
+ , Plain $ docNameToDoc l
+ , plaintext " -> "
+ , Plain $ hsep $ map (docNameToDoc . unLoc) rs
+ ]
+ppLInjectivityAnn _ = [plaintext $ unimp "LInjectivityAnn"]
+
+ppFamilyResultSig :: FamilyResultSig DocNameI -> [OrgInline]
+ppFamilyResultSig (KindSig _ (L _ x)) =
+ [Whitespace, plaintext "::", Whitespace] ++ ppHsType x
+ppFamilyResultSig (NoSig{}) = []
+ppFamilyResultSig (TyVarSig _ x) =
+ [Whitespace, plaintext "=", Whitespace] ++ ppLHsTyVarBndr x
+
+ppDataDefn :: HsDataDefn DocNameI -> SubDocs -> ModPath -> Int -> [OrgBlock]
+ppDataDefn (HsDataDefn _ _ _ _ _ cons _derivs) subdocs path level =
+ concatMap ((\con -> ppConDecl con subdocs path level) . unLoc) cons
+ppDataDefn _ _ _ level = [unimpHeading "DataDecl" level]
+
+ppConDecl :: ConDecl DocNameI -> SubDocs -> ModPath -> Int -> [OrgBlock]
+-- T1 a Int
+-- TODO: handle infix
+ppConDecl (ConDeclH98 _ (L _ docName) _forall exTvs mbCtxt args _) subdocs path level
+ = Heading
+ level
+ (interNotNull
+ [Whitespace]
+ [ ppForAll exTvs
+ , ppMbLHsContext mbCtxt
+ , [Plain (docNameToDoc docName)]
+ , prefixOnly
+ ]
+ )
+ (cIdPaths path docName)
+ : case lookup docName subdocs of
+ Just (doc, aDoc) ->
+ prefixWithDocs aDoc ++ ppDocumentation doc (Just level)
+ Nothing -> []
+ ++ ppConDeclRecCon args subdocs path (level + 1)
+ where
+ prefixOnly = case args of
+ PrefixCon _ args' -> interNotNull [Whitespace] (map ppHsScaled args')
+ RecCon _ -> [plaintext "{"]
+ _ -> []
+ prefixWithDocs :: FnArgsDoc DocName -> [OrgBlock]
+ prefixWithDocs aDoc = if M.null aDoc
+ then []
+ else case args of
+ PrefixCon _ args' ->
+ [ Paragraph [plaintext "Arguments:"]
+ , DefList
+ (map (\(i, arg) -> (ppHsScaled arg, ppADoc aDoc i)) (zip [1 ..] args')
+ )
+ ]
+ _ -> ppFnArgsDoc aDoc
+-- TODO: handle con_bndrs and con_mb_cxt
+ppConDecl (ConDeclGADT _ names _ _ args resTy _) subdocs path level =
+ [ Heading
+ level
+ ( interNotNull
+ [Whitespace]
+ [ intersperse (Plain $ text ", ")
+ (map (Plain . docNameToDoc . unLoc) names)
+ , [plaintext "::"]
+ ]
+ ++ [Whitespace]
+ ++ ppConDeclGADTDetailsPrefix args resTy
+ )
+ (concatMap (cIdPaths path . unLoc) names)
+ ]
+ ++ maybe []
+ (`ppDocForDecl` (Just level))
+ (lookup (unLoc $ head names) subdocs)
+ ++ ppConDeclGADTDetailsRec args resTy subdocs path (level + 1)
+
+
+ppForAll :: [LHsTyVarBndr a DocNameI] -> [OrgInline]
+ppForAll [] = []
+ppForAll xs =
+ intercalate [Whitespace] ([plaintext "forall"] : map ppLHsTyVarBndr xs)
+ ++ [plaintext "."]
+
+ppConDeclGADTDetailsPrefix
+ :: HsConDeclGADTDetails DocNameI -> LHsType DocNameI -> [OrgInline]
+ppConDeclGADTDetailsPrefix (PrefixConGADT args) resTy =
+ intercalate [plaintext " -> "] (map ppHsScaled args ++ [ppLHsType resTy])
+ppConDeclGADTDetailsPrefix (RecConGADT{}) _ = [plaintext "{"]
+
+ppConDeclGADTDetailsRec
+ :: HsConDeclGADTDetails DocNameI
+ -> LHsType DocNameI
+ -> SubDocs
+ -> ModPath
+ -> Int
+ -> [OrgBlock]
+ppConDeclGADTDetailsRec (RecConGADT (L _ args)) resTy subdocs path level =
+ concatMap (\arg -> ppConDeclField (unLoc arg) subdocs path level) args
+ ++ [Heading level (plaintext "} -> " : ppLHsType resTy) []]
+ppConDeclGADTDetailsRec _ _ _ _ _ = []
+
+ppConDeclRecCon
+ :: HsConDeclH98Details DocNameI -> SubDocs -> ModPath -> Int -> [OrgBlock]
+ppConDeclRecCon (RecCon (L _ args)) subdocs path level =
+ concatMap (\arg -> ppConDeclField (unLoc arg) subdocs path level) args
+ppConDeclRecCon _ _ _ _ = []
+
+ppConDeclField
+ :: ConDeclField DocNameI -> SubDocs -> ModPath -> Int -> [OrgBlock]
+ppConDeclField (ConDeclField _ names (L _ ty) _) subdocs path level =
+ [ Heading
+ level
+ (interNotNull
+ [Whitespace]
+ [ intersperse
+ (Plain $ text ", ")
+ (map (Plain . docNameToDoc . fieldOccDocName . unLoc) names)
+ , [plaintext "::"]
+ , ppHsType ty
+ ]
+ )
+ (concatMap (cIdPaths path . fieldOccDocName . unLoc) names)
+ ]
+ ++ maybe [] (`ppDocForDecl` (Just level)) (lookup docName subdocs)
+ where docName = (fieldOccDocName . unLoc . head) names
+
+fieldOccDocName :: FieldOcc DocNameI -> DocName
+fieldOccDocName (FieldOcc docName _) = docName
+fieldOccDocName _ = error "FieldOccDocName"
+
+-- TODO: handle linear types
+ppHsScaled :: HsScaled DocNameI (LHsType DocNameI) -> [OrgInline]
+ppHsScaled (HsScaled _ (L _ ty)) = ppHsType ty
+
+ppSig
+ :: Sig DocNameI
+ -> DocForDecl DocName
+ -> SubDocs
+ -> ModPath
+ -> Int
+ -> [OrgBlock]
+-- toplevel decl e.g. f :: Int -> String
+ppSig (TypeSig _ lhs rhs) (doc, aDoc) _ path level =
+ Heading
+ level
+ ( [ Plain (hsep $ punctuate comma $ docNameToDoc . unLoc <$> lhs)
+ , Whitespace
+ , plaintext "::"
+ , Whitespace
+ ]
+ ++ (ppHsSigType hsSig)
+ )
+ (concatMap (cIdPaths path . unLoc) lhs)
+ : (if M.null aDoc then [] else ppHsSigTypeDoc hsSig aDoc)
+ ++ ppDocumentation doc (Just level)
+ where hsSig = unLoc (dropWildCards rhs)
+-- class method decl
+ppSig (ClassOpSig _ _ names (L _ sigType)) _ subdocs path level =
+ [ Heading
+ level
+ ( [ Plain (hsep $ punctuate comma $ docNameToDoc . unLoc <$> names)
+ , Whitespace
+ , plaintext "::"
+ , Whitespace
+ ]
+ ++ ppHsSigType sigType
+ )
+ (concatMap (cIdPaths path . unLoc) names)
+ ]
+ ++ case lookup (unLoc (head names)) subdocs of
+ Just (doc, aDoc) ->
+ (if M.null aDoc then [] else ppHsSigTypeDoc sigType aDoc)
+ ++ ppDocumentation doc (Just level)
+ Nothing -> []
+ppSig (PatSynSig _ names (L _ hsSig)) (doc, aDoc) _ path level =
+ Heading
+ level
+ ( [ plaintext "pattern "
+ , Plain (hsep $ punctuate comma $ docNameToDoc . unLoc <$> names)
+ , Whitespace
+ , plaintext "::"
+ , Whitespace
+ ]
+ ++ (ppHsSigType hsSig)
+ )
+ (concatMap (cIdPaths path . unLoc) names)
+ : (if M.null aDoc then [] else ppHsSigTypeDoc hsSig aDoc)
+ ++ ppDocumentation doc (Just level)
+
+-- TODO: every class's sigs start with a MinimalSig
+ppSig (MinimalSig{}) _ _ _ _ = []
+ppSig _ _ _ _ level = [headingPlainText (unimp "Sig") level]
+
+ppNewOrData :: NewOrData -> PDoc
+ppNewOrData NewType = text "newtype"
+ppNewOrData DataType = text "data"
+
+ppHsSigType :: HsSigType DocNameI -> [OrgInline]
+ppHsSigType (HsSig _ bndrs (L _ ty)) = interNotNull
+ [Whitespace]
+ [ppHsOuterSigTyVarBndrs bndrs, ppHsType (reparenTypePrec PREC_TOP ty)]
+
+ppHsOuterSigTyVarBndrs :: HsOuterSigTyVarBndrs DocNameI -> [OrgInline]
+ppHsOuterSigTyVarBndrs bndrs = case bndrs of
+ HsOuterExplicit _ tyVarBndrs -> ppForAll tyVarBndrs
+ _ -> []
+
+ppHsSigTypeDoc :: HsSigType DocNameI -> FnArgsDoc DocName -> [OrgBlock]
+ppHsSigTypeDoc (HsSig _ bndrs (L _ ty)) adoc =
+ [Paragraph [plaintext "Arguments:"], DefList (forall ++ ppHsTypeDoc ty 0)]
+ where
+ ppHsTypeDoc :: HsType DocNameI -> Int -> [DefListItem]
+ ppHsTypeDoc (HsFunTy _ _ (L _ lTy) (L _ rTy)) i =
+ ppHsTypeDoc lTy i ++ ppHsTypeDoc rTy (i + 1)
+ ppHsTypeDoc (HsQualTy _ mbCtxt (L _ body)) i =
+ (ppMbLHsContext mbCtxt, []) : ppHsTypeDoc body i
+ ppHsTypeDoc (HsForAllTy _ tele (L _ body)) i =
+ (ppHsForAllTelescope tele ++ [plaintext "."], []) : ppHsTypeDoc body i
+ ppHsTypeDoc typ i = [(ppHsType typ, ppADoc adoc i)]
+ forall = case ppHsOuterSigTyVarBndrs bndrs of
+ [] -> []
+ is -> [(is, [])]
+
+ppDocForDecl :: DocForDecl DocName -> Maybe Int -> [OrgBlock]
+ppDocForDecl (doc, adoc) l = ppFnArgsDoc adoc ++ ppDocumentation doc l
+
+ppADoc :: FnArgsDoc DocName -> Int -> [OrgBlock]
+ppADoc adoc i = case adoc !? i of
+ Nothing -> []
+ Just mdoc -> ppMDoc mdoc Nothing
+
+ppHsType :: HsType DocNameI -> [OrgInline]
+-- e.g. -> forall d. d
+ppHsType (HsForAllTy _ tele (L _ body)) =
+ ppHsForAllTelescope tele ++ [plaintext ".", Whitespace] ++ ppHsType body
+-- e.g. forall a. Ord a => a
+ppHsType (HsQualTy _ mbCtxt (L _ body)) =
+ interNotNull [Whitespace] [ppMbLHsContext mbCtxt, ppHsType body]
+-- e.g. Bool
+ppHsType (HsTyVar _ promo (L _ docName)) =
+ ppPromoted promo ++ ppDocName docName
+-- e.g. IO ()
+ppHsType (HsAppTy _ (L _ lTy) (L _ rTy)) =
+ ppHsType lTy ++ [Whitespace] ++ ppHsType rTy
+ppHsType (HsAppKindTy _ _ _) = [plaintext $ unimp "HsAppKindTy"]
+ppHsType (HsFunTy _ _ (L _ lTy) (L _ rTy)) =
+ ppHsType lTy ++ [Whitespace, plaintext "->", Whitespace] ++ ppHsType rTy
+-- e.g. [a]
+ppHsType (HsListTy _ (L _ ty) ) = orgBrackets $ ppHsType ty
+-- e.g. ()
+-- e.g. (a, b)
+ppHsType (HsTupleTy _ sort tys) = orgParens $ maybeUnbox $ intercalate
+ [plaintext ",", Whitespace]
+ (ppHsType . unLoc <$> tys)
+ where
+ maybeUnbox = case sort of
+ HsUnboxedTuple -> orgUnbox
+ HsBoxedOrConstraintTuple -> id
+-- e.g. (# a | b #)
+ppHsType (HsSumTy _ tys) =
+ orgParens . orgUnbox $ intercalate [plaintext " | "] (map ppLHsType tys)
+ppHsType (HsOpTy _ (L _ lTy) (L _ docName) (L _ rTy)) =
+ intercalate [Whitespace] [ppHsType lTy, ppDocName docName, ppHsType rTy]
+-- e.g. (a -> a)
+ppHsType (HsParTy _ (L _ t)) = orgParens $ ppHsType t
+-- e.g. ?callStack :: CallStack
+ppHsType (HsIParamTy _ (L _ name) ty) =
+ (plaintext $ '?' : unpackFS (hsIPNameFS name))
+ : plaintext " :: "
+ : ppLHsType ty
+ppHsType (HsStarTy _ _) = [plaintext "*"]
+-- e.g. (a :: k)
+ppHsType (HsKindSig _ (L _ t) (L _ k)) =
+ ppHsType t ++ [plaintext " :: "] ++ ppHsType k
+ppHsType (HsSpliceTy _ _ ) = [plaintext $ unimp "HsSpliceTy"]
+-- e.g. -> a -- ^ Second argument
+-- The third arg in docty is HsDocString
+ppHsType (HsDocTy _ (L _ t) _ ) = ppHsType t
+ppHsType (HsBangTy _ _ (L _ ty) ) = plaintext "!" : ppHsType ty
+ppHsType (HsRecTy _ _ ) = [plaintext $ unimp "HsRecTy"]
+-- TODO: is it possible that promo is NotPromoted? If so what is the difference
+-- from a vanilla list (cf ExplicitTuple does not have a promo flag)?
+ppHsType (HsExplicitListTy _ promo tys) = ppPromoted promo
+ ++ orgBrackets (intercalate [plaintext ", "] (map ppLHsType tys))
+ppHsType (HsExplicitTupleTy _ tys) =
+ plaintext "'" : orgParens (intercalate [plaintext ", "] (map ppLHsType tys))
+ppHsType (HsTyLit _ lit) = [plaintext $ shown]
+ where
+ shown = case lit of
+ HsNumTy _ x -> show x
+ HsStrTy _ x -> show x
+ HsCharTy _ x -> show x
+ppHsType (HsWildCardTy _) = [plaintext "_"]
+ppHsType _ = [plaintext $ unimp "HsType"]
+
+ppLHsType :: LHsType DocNameI -> [OrgInline]
+ppLHsType (L _ x) = ppHsType x
+
+ppMbLHsContext :: Maybe (LHsContext DocNameI) -> [OrgInline]
+ppMbLHsContext = maybe [] (ppContext . map unLoc . unLoc)
+
+ppContext :: [HsType DocNameI] -> [OrgInline]
+ppContext [] = []
+ppContext ctx =
+ parensIfMany ctx (intercalate [plaintext ",", Whitespace] (map ppHsType ctx))
+ ++ [Whitespace, plaintext "=>"]
+
+ppPromoted :: PromotionFlag -> [OrgInline]
+ppPromoted flag = case flag of
+ NotPromoted -> []
+ IsPromoted -> [plaintext "'"]
+
+ppDocName :: DocName -> [OrgInline]
+ppDocName docName@(Documented _ mdl) =
+ [Link (text "#" <> text (idPath' mdl docName)) [Plain $ docNameToDoc docName]]
+ppDocName docName@(Undocumented name) = case nameModule_maybe name of
+ Nothing -> [Plain $ docNameToDoc docName]
+ Just mdl -> ppDocName (Documented name mdl)
+
+-- TODO: determine whether it's a subordinate based on NameSpace
+ppMO :: (ModuleName, OccName) -> [OrgInline]
+ppMO (mdl, occ) =
+ [ Link (text $ "#" ++ moToString (mdl, occ))
+ [plaintext $ moToString (mdl, occ)]
+ ]
+
+ppHsForAllTelescope :: HsForAllTelescope DocNameI -> [OrgInline]
+ppHsForAllTelescope (HsForAllInvis _ bndrs) =
+ intercalate [Whitespace] ([plaintext "forall"] : map ppLHsTyVarBndr bndrs)
+ppHsForAllTelescope _ = [plaintext $ unimp "HsForAllTelescope"]
+
+ppLHsTyVarBndr :: LHsTyVarBndr a DocNameI -> [OrgInline]
+ppLHsTyVarBndr (L _ x) = ppHsTyVarBndr x
+
+ppHsTyVarBndr :: HsTyVarBndr a DocNameI -> [OrgInline]
+ppHsTyVarBndr (UserTyVar _ _ (L _ docName)) = [Plain $ docNameToDoc docName]
+ppHsTyVarBndr (KindedTyVar _ _ (L _ docName) (L _ ty)) =
+ orgParens $ Plain (docNameToDoc docName) : plaintext " :: " : ppHsType ty
+
+ppOccName :: OccName -> PDoc
+ppOccName = text . occNameString
+
+ppName :: Name -> PDoc
+ppName = ppOccName . nameOccName
+
+docNameToDoc :: DocName -> PDoc
+docNameToDoc = ppName . getName
+
+docNameToString :: DocName -> String
+docNameToString = occNameString . nameOccName . getName
+
+ppWrapped :: (a -> [OrgInline]) -> Wrap a -> [OrgInline]
+ppWrapped p (Unadorned n) = p n
+ppWrapped p (Parenthesized n) = orgParens $ p n
+ppWrapped p (Backticked n) = plaintext "`" : p n ++ [plaintext "`"]
+
+wrapDocNameToString :: Wrap DocName -> String
+wrapDocNameToString = showWrapped docNameToString
+
+wrapMOToString :: Wrap (ModuleName, OccName) -> String
+wrapMOToString = showWrapped moToString
+
+moToString :: (ModuleName, OccName) -> String
+moToString (mdl, occ) = moduleNameString mdl ++ "." ++ occNameString occ
+
+removeMarkup :: Doc DocName -> String
+removeMarkup = markup (plainMarkup wrapMOToString wrapDocNameToString)
+
+removeMarkup' :: Doc RdrName -> String
+removeMarkup' = markup (plainMarkup wrapMOToString (showWrapped showPprUnsafe))
+
+orgUnbox :: [OrgInline] -> [OrgInline]
+orgUnbox xs = interNotNull [Whitespace] [[plaintext "#"], xs, [plaintext "#"]]
+
+-- * Utilities
+
+interNotNull :: [a] -> [[a]] -> [a]
+interNotNull xs = intercalate xs . filter (not . null)
+
+tyvarNames :: LHsQTyVars DocNameI -> [Name]
+tyvarNames = map (getName . hsLTyVarNameI) . hsQTvExplicit
+
+ppLHsQTyVars :: LHsQTyVars DocNameI -> [OrgInline]
+ppLHsQTyVars (HsQTvs _ bndrs) =
+ intercalate [Whitespace] (map ppLHsTyVarBndr bndrs)
+ppLHsQTyVars _ = [plaintext $ unimp "LHsQTyVars"]
+
+isBlock :: DocH mod id -> Bool
+isBlock DocEmpty = True
+isBlock (DocAppend x y ) = isBlock x || isBlock y
+isBlock (DocString _) = False
+isBlock (DocParagraph _) = True
+isBlock (DocIdentifier _) = False
+isBlock (DocIdentifierUnchecked _) = False
+isBlock (DocModule _) = False
+isBlock (DocWarning _) = False
+isBlock (DocEmphasis _) = False
+isBlock (DocMonospaced _) = False
+isBlock (DocBold _) = False
+isBlock (DocUnorderedList _) = True
+isBlock (DocOrderedList _) = True
+isBlock (DocDefList _) = True
+isBlock (DocCodeBlock _) = True
+isBlock (DocHyperlink _) = False
+isBlock (DocPic _) = False
+isBlock (DocMathInline _) = False
+isBlock (DocMathDisplay _) = True
+isBlock (DocAName _) = False
+isBlock (DocProperty _) = False
+isBlock (DocExamples _) = True
+isBlock (DocHeader _) = True
+isBlock (DocTable _) = True
+
+cleanPkgStr :: String -> String
+cleanPkgStr = removeHash . removeInplace
+
+removeInplace :: String -> String
+removeInplace s | isSuffixOf "-inplace" s = take (length s - 8) s
+removeInplace s = s
+
+-- A silly heuristic that removes the last 65 chars if the string is longer than 65 chars
+-- useful for removing hash from a unit id string like
+-- sqlite-simple-0.4.18.2-fe5243655374e8f6ef336683926e98123d2de2f3265d2b935e0897c09586970b
+removeHash :: String -> String
+removeHash s | length s > 65 = take (length s - 65) s
+removeHash s = s
+
+hackagePackageUrl :: String -> String
+hackagePackageUrl pkg = "https://hackage.haskell.org/package/" ++ pkg
+
+hackageModuleUrl :: String -> String -> String
+hackageModuleUrl pkg mdl =
+ hackagePackageUrl pkg ++ "/docs/" ++ dotsToDashes mdl ++ ".html"
+ where dotsToDashes = map (\c -> if c == '.' then '-' else c)
+
+-- * Orphan instances for show
+
+instance Show DocName where
+ show = showPprUnsafe
+
+instance Show OccName where
+ show = showPprUnsafe
diff --git a/haddock-api/src/Haddock/Backends/Org/Types.hs b/haddock-api/src/Haddock/Backends/Org/Types.hs
new file mode 100644
index 00000000..9e3534c3
--- /dev/null
+++ b/haddock-api/src/Haddock/Backends/Org/Types.hs
@@ -0,0 +1,260 @@
+{-
+Copyright (C) 2022 Yuchen Pei.
+
+This file is part of haddorg-api.
+
+This file 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 file 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 file. If not, see
+<https://www.gnu.org/licenses/>.
+-}
+
+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, FlexibleContexts #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Haddock.Backends.Org.Types where
+
+import Data.Char ( isSpace )
+import Data.List ( dropWhileEnd
+ , intercalate
+ )
+import Data.Map ( Map )
+import GHC.Utils.Ppr ( ($$)
+ , (<+>)
+ , (<>)
+ , Doc
+ , Mode(..)
+ , brackets
+ , empty
+ , fullRender
+ , hang
+ , hcat
+ , hsep
+ , punctuate
+ , text
+ , txtPrinter
+ , vcat
+ )
+import Prelude hiding ( (<>) )
+
+-- * Some consts
+defListSep :: Doc
+defListSep = text "::"
+
+unorderedBullet, orderedBullet :: String
+unorderedBullet = "-"
+orderedBullet = "."
+
+colons :: Doc -> Doc
+colons doc = text ":" <> doc <> text ":"
+
+-- * Document, Sections and Headings
+
+data OrgDocument = OrgDocument
+ { oDKeywords :: Map String Doc
+ , oDBlocks :: [OrgBlock]
+ }
+ deriving Show
+
+-- todo: handle keywords
+
+type Properties = [(String, String)]
+
+-- * Blocks
+
+-- | Org block. Like a Pandoc Block.
+data OrgBlock
+ = Heading Int [OrgInline] Properties
+ | PlainList ListType [[OrgBlock]]
+ | DefList [DefListItem]
+ | Paragraph [OrgInline]
+ | Table [[[OrgInline]]] [[[OrgInline]]]
+ | SrcBlock Doc
+ | MathDisplay Doc
+ | Example Doc Doc -- expression and result
+ deriving (Show)
+
+-- Lists
+
+data ListType = Ordered | Unordered
+ deriving (Show)
+
+type DefListItem = ([OrgInline], [OrgBlock])
+
+-- * Inlines
+
+-- | Objects (inline elements). Derived from Pandoc's Inline.
+data OrgInline
+ = Plain Doc
+ | Italic [OrgInline]
+ | Bold [OrgInline]
+ | Code Doc
+ | Link Doc [OrgInline]
+ | Anchor Doc
+ | Whitespace
+ | MathInline Doc
+ deriving (Show)
+
+-- * From Org elements to Doc
+
+fromOrgDocument :: OrgDocument -> Doc
+fromOrgDocument (OrgDocument _ blocks) = fromOrgBlocks blocks <> text "\n"
+
+fromOrgBlock :: OrgBlock -> Doc
+fromOrgBlock (Heading level inlines props) = hang
+ (text (replicate level '*') <+> fromOrgInlines inlines)
+ (level + 1)
+ (fromOrgProperties props)
+fromOrgBlock (Paragraph inlines) = fromOrgInlines inlines
+fromOrgBlock (SrcBlock code) =
+ -- The \n followed by <> code makes indentation work, given the code has no indent
+ vcat [text "#+begin_src haskell\n" <> code, text "#+end_src"]
+fromOrgBlock (DefList defs) = vcat $ map
+ (\(term, def) -> fromOrgListItem
+ unorderedBullet
+ (prependInlinesToBlocks (term ++ [Whitespace, plaintext "::", Whitespace])
+ def
+ )
+ )
+ defs
+fromOrgBlock (PlainList Unordered items) =
+ vcat $ map (uncurry fromOrgListItem) (zip (repeat unorderedBullet) items)
+fromOrgBlock (PlainList Ordered items) = vcat $ map
+ (uncurry fromOrgListItem)
+ (zip (map ((++ orderedBullet) . show) [1 ..]) items)
+fromOrgBlock (Example expr res) =
+ (fromOrgBlock (SrcBlock expr)) $$ (text "#+RESULTS:") $$ res
+fromOrgBlock (MathDisplay doc) = doc
+fromOrgBlock (Table header body) =
+ vcat (map fromOrgTableRow header) $$ tableRule len $$ vcat
+ (map fromOrgTableRow body)
+ where
+ len = case header of
+ [] -> case body of
+ [] -> 0
+ h : _ -> length h
+ h : _ -> length h
+
+tableRule :: Int -> Doc
+tableRule n =
+ text "|" <> hcat (punctuate (text "|") (replicate n (text "-"))) <> text "|"
+
+fromOrgTableRow :: [[OrgInline]] -> Doc
+fromOrgTableRow row =
+ text "|" <+> hsep (punctuate (text "|") (map fromOrgInlines row)) <+> text "|"
+
+prependInlinesToBlock :: [OrgInline] -> OrgBlock -> [OrgBlock]
+prependInlinesToBlock [] block = [block]
+prependInlinesToBlock _ (Heading _ _ _) =
+ error "Prepending inlines to a heading!"
+prependInlinesToBlock is (Paragraph is') = [Paragraph (is ++ is')]
+prependInlinesToBlock is block = [Paragraph is, block]
+
+prependInlinesToBlocks :: [OrgInline] -> [OrgBlock] -> [OrgBlock]
+prependInlinesToBlocks is [] = [Paragraph is]
+prependInlinesToBlocks is (h : t) = prependInlinesToBlock is h ++ t
+
+fromOrgProperties :: Properties -> Doc
+fromOrgProperties props | null props = empty
+fromOrgProperties props =
+ colons (text "PROPERTIES")
+ $$ vcat (map (\(prop, value) -> colons (text prop) <+> text value) props)
+ $$ colons (text "END")
+
+fromOrgBlocks :: [OrgBlock] -> Doc
+fromOrgBlocks = vcat . punctuate (text "\n") . map fromOrgBlock
+
+fromOrgBlocksTight :: [OrgBlock] -> Doc
+fromOrgBlocksTight = vcat . map fromOrgBlock
+
+fromOrgListItem :: String -> [OrgBlock] -> Doc
+fromOrgListItem _ [] = empty
+fromOrgListItem bullet (hd : rest) = hang (text bullet <+> fromOrgBlock hd)
+ (length bullet + 1)
+ (fromOrgBlocksTight rest)
+
+fromOrgInline :: OrgInline -> Doc
+fromOrgInline (Plain doc ) = doc
+fromOrgInline (Code doc ) = text "~" <> doc <> text "~"
+fromOrgInline (Link target label) = brackets $ brackets target <> if null label
+ then empty
+ else brackets (fromOrgInlines label)
+fromOrgInline (Bold inlines) = text "*" <> fromOrgInlines inlines <> text "*"
+fromOrgInline (Italic inlines) = text "/" <> fromOrgInlines inlines <> text "/"
+fromOrgInline (Anchor doc ) = text "<<" <> doc <> text ">>"
+fromOrgInline Whitespace = text " "
+fromOrgInline (MathInline doc) = text "\\(" <+> doc <+> text "\\)"
+
+fromOrgInlines :: [OrgInline] -> Doc
+fromOrgInlines = hcat . map fromOrgInline
+
+-- * To string
+
+orgToString :: Doc -> String
+orgToString = fullRender (PageMode True) 0 1 txtPrinter ""
+
+-- * Utilities for creating org elements
+
+cIdProp :: String -> Properties
+cIdProp cid = [("CUSTOM_ID", cid)]
+
+hackageProp :: String -> Properties
+hackageProp url = [("Hackage", url)]
+
+cIdsProp :: [String] -> Properties
+cIdsProp cids = map (\cid -> ("CUSTOM_ID", cid)) cids
+
+plaintext :: String -> OrgInline
+plaintext = Plain . text . unfill
+
+unfill :: String -> String
+unfill "" = ""
+unfill s =
+ let
+ xs = lines s
+ preStripped = head xs : map (dropWhile isSpace) (tail xs)
+ stripped =
+ map (dropWhileEnd isSpace) (init preStripped) ++ [last preStripped]
+ in
+ unwords stripped
+
+fixLeadingStar :: String -> String
+fixLeadingStar =
+ intercalate "\n"
+ . map
+ (\line ->
+ if not (null line) && head line == '*' then ' ' : line else line
+ )
+ . lines
+
+headingPlainText :: String -> Int -> OrgBlock
+headingPlainText title level = Heading level [plaintext title] []
+
+headingPlainTextCId :: String -> String -> Int -> OrgBlock
+headingPlainTextCId title cid level =
+ Heading level [plaintext title] (cIdProp cid)
+
+singleHeadingPlainText :: String -> Int -> [OrgBlock]
+singleHeadingPlainText title level = [headingPlainText title level]
+
+singleHeadingPlain :: Doc -> Int -> [OrgBlock]
+singleHeadingPlain title level = [Heading level [Plain title] []]
+
+singleHeadingPlainCId :: Doc -> String -> Int -> [OrgBlock]
+singleHeadingPlainCId title cid level =
+ [Heading level [Plain title] (cIdProp cid)]
+
+orgParens :: [OrgInline] -> [OrgInline]
+orgParens xs = plaintext "(" : xs ++ [plaintext ")"]
+
+orgBrackets :: [OrgInline] -> [OrgInline]
+orgBrackets xs = plaintext "[" : xs ++ [plaintext "]"]
diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs
index 78bfe1a1..e9fd0c5d 100644
--- a/haddock-api/src/Haddock/Options.hs
+++ b/haddock-api/src/Haddock/Options.hs
@@ -12,53 +12,56 @@
--
-- Definition of the command line interface of Haddock.
-----------------------------------------------------------------------------
-module Haddock.Options (
- parseHaddockOpts,
- Flag(..),
- Visibility(..),
- getUsage,
- optTitle,
- outputDir,
- optContentsUrl,
- optIndexUrl,
- optCssFile,
- optSourceCssFile,
- sourceUrls,
- wikiUrls,
- baseUrl,
- optParCount,
- optDumpInterfaceFile,
- optShowInterfaceFile,
- optLaTeXStyle,
- optMathjax,
- qualification,
- sinceQualification,
- verbosity,
- ghcFlags,
- reexportFlags,
- readIfaceArgs,
- optPackageName,
- optPackageVersion,
- modulePackageInfo,
- ignoredSymbols
-) where
-
-
-import qualified Data.Char as Char
-import Data.Version
+module Haddock.Options
+ ( parseHaddockOpts
+ , Flag(..)
+ , Visibility(..)
+ , getUsage
+ , optTitle
+ , outputDir
+ , optContentsUrl
+ , optIndexUrl
+ , optCssFile
+ , optSourceCssFile
+ , sourceUrls
+ , wikiUrls
+ , baseUrl
+ , optParCount
+ , optDumpInterfaceFile
+ , optShowInterfaceFile
+ , optLaTeXStyle
+ , optMathjax
+ , qualification
+ , sinceQualification
+ , verbosity
+ , ghcFlags
+ , reexportFlags
+ , readIfaceArgs
+ , optPackageName
+ , optPackageVersion
+ , modulePackageInfo
+ , ignoredSymbols
+ ) where
+
+
import Control.Applicative
+import qualified Data.Char as Char
+import Data.Version
+import GHC ( Module
+ , moduleUnit
+ )
import GHC.Data.FastString
-import GHC ( Module, moduleUnit )
import GHC.Unit.State
import Haddock.Types
import Haddock.Utils
import System.Console.GetOpt
-import qualified Text.ParserCombinators.ReadP as RP
+import qualified Text.ParserCombinators.ReadP as RP
data Flag
= Flag_BuiltInThemes
| Flag_CSS String
+ | Flag_Org
-- | Flag_DocBook
| Flag_ReadInterface String
| Flag_DumpInterface String
@@ -120,119 +123,231 @@ data Flag
options :: Bool -> [OptDescr Flag]
options backwardsCompat =
- [
- Option ['B'] [] (ReqArg Flag_GhcLibDir "DIR")
- "path to a GHC lib dir, to override the default path",
- Option ['o'] ["odir"] (ReqArg Flag_OutputDir "DIR")
- "directory in which to put the output files",
- Option ['l'] ["lib"] (ReqArg Flag_Lib "DIR")
- "location of Haddock's auxiliary files",
- Option ['i'] ["read-interface"] (ReqArg Flag_ReadInterface "FILE")
- "read an interface from FILE",
- Option ['D'] ["dump-interface"] (ReqArg Flag_DumpInterface "FILE")
- "write the resulting interface to FILE",
- Option [] ["show-interface"] (ReqArg Flag_ShowInterface "FILE")
- "print the interface in a human readable form",
+ [ Option ['B']
+ []
+ (ReqArg Flag_GhcLibDir "DIR")
+ "path to a GHC lib dir, to override the default path"
+ , Option ['o']
+ ["odir"]
+ (ReqArg Flag_OutputDir "DIR")
+ "directory in which to put the output files"
+ , Option ['l']
+ ["lib"]
+ (ReqArg Flag_Lib "DIR")
+ "location of Haddock's auxiliary files"
+ , Option ['i']
+ ["read-interface"]
+ (ReqArg Flag_ReadInterface "FILE")
+ "read an interface from FILE"
+ , Option ['D']
+ ["dump-interface"]
+ (ReqArg Flag_DumpInterface "FILE")
+ "write the resulting interface to FILE"
+ , Option []
+ ["show-interface"]
+ (ReqArg Flag_ShowInterface "FILE")
+ "print the interface in a human readable form"
+ ,
-- Option ['S'] ["docbook"] (NoArg Flag_DocBook)
-- "output in DocBook XML",
- Option ['h'] ["html"] (NoArg Flag_Html)
- "output in HTML (XHTML 1.0)",
- Option [] ["latex"] (NoArg Flag_LaTeX) "use experimental LaTeX rendering",
- Option [] ["latex-style"] (ReqArg Flag_LaTeXStyle "FILE") "provide your own LaTeX style in FILE",
- Option [] ["mathjax"] (ReqArg Flag_Mathjax "URL") "URL FOR mathjax",
- Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output",
- Option [] ["hoogle"] (NoArg Flag_Hoogle)
- "output for Hoogle; you may want --package-name and --package-version too",
- Option [] ["quickjump"] (NoArg Flag_QuickJumpIndex)
- "generate an index for interactive documentation navigation",
- Option [] ["hyperlinked-source"] (NoArg Flag_HyperlinkedSource)
- "generate highlighted and hyperlinked source code (for use with --html)",
- Option [] ["source-css"] (ReqArg Flag_SourceCss "FILE")
- "use custom CSS file instead of default one in hyperlinked source",
- Option [] ["source-base"] (ReqArg Flag_SourceBaseURL "URL")
- "URL for a source code link on the contents\nand index pages",
- Option ['s'] (if backwardsCompat then ["source", "source-module"] else ["source-module"])
- (ReqArg Flag_SourceModuleURL "URL")
- "URL for a source code link for each module\n(using the %{FILE} or %{MODULE} vars)",
- Option [] ["source-entity"] (ReqArg Flag_SourceEntityURL "URL")
- "URL for a source code link for each entity\n(using the %{FILE}, %{MODULE}, %{NAME},\n%{KIND} or %{LINE} vars)",
- Option [] ["source-entity-line"] (ReqArg Flag_SourceLEntityURL "URL")
- "URL for a source code link for each entity.\nUsed if name links are unavailable, eg. for TH splices.",
- Option [] ["comments-base"] (ReqArg Flag_WikiBaseURL "URL")
- "URL for a comments link on the contents\nand index pages",
- Option [] ["base-url"] (ReqArg Flag_BaseURL "URL")
- "Base URL for static assets (eg. css, javascript, json files etc.).\nWhen given statis assets will not be copied.",
- Option [] ["comments-module"] (ReqArg Flag_WikiModuleURL "URL")
- "URL for a comments link for each module\n(using the %{MODULE} var)",
- Option [] ["comments-entity"] (ReqArg Flag_WikiEntityURL "URL")
- "URL for a comments link for each entity\n(using the %{FILE}, %{MODULE}, %{NAME},\n%{KIND} or %{LINE} vars)",
- Option ['c'] ["css", "theme"] (ReqArg Flag_CSS "PATH")
- "the CSS file or theme directory to use for HTML output",
- Option [] ["built-in-themes"] (NoArg Flag_BuiltInThemes)
- "include all the built-in haddock themes",
- Option ['p'] ["prologue"] (ReqArg Flag_Prologue "FILE")
- "file containing prologue text",
- Option ['t'] ["title"] (ReqArg Flag_Heading "TITLE")
- "page heading",
- Option ['q'] ["qual"] (ReqArg Flag_Qualification "QUAL")
- "qualification of names, one of \n'none' (default), 'full', 'local'\n'relative' or 'aliased'",
- Option ['?'] ["help"] (NoArg Flag_Help)
- "display this help and exit",
- Option ['V'] ["version"] (NoArg Flag_Version)
- "output version information and exit",
- Option [] ["compatible-interface-versions"] (NoArg Flag_CompatibleInterfaceVersions)
- "output compatible interface file versions and exit",
- Option [] ["interface-version"] (NoArg Flag_InterfaceVersion)
- "output interface file version and exit",
- Option [] ["bypass-interface-version-check"] (NoArg Flag_BypassInterfaceVersonCheck)
- "bypass the interface file version check (dangerous)",
- Option ['v'] ["verbosity"] (ReqArg Flag_Verbosity "VERBOSITY")
- "set verbosity level",
- Option [] ["use-contents"] (ReqArg Flag_UseContents "URL")
- "use a separately-generated HTML contents page",
- Option [] ["gen-contents"] (NoArg Flag_GenContents)
- "generate an HTML contents from specified\ninterfaces",
- Option [] ["use-index"] (ReqArg Flag_UseIndex "URL")
- "use a separately-generated HTML index",
- Option [] ["gen-index"] (NoArg Flag_GenIndex)
- "generate an HTML index from specified\ninterfaces",
- Option [] ["ignore-all-exports"] (NoArg Flag_IgnoreAllExports)
- "behave as if all modules have the\nignore-exports attribute",
- Option [] ["hide"] (ReqArg Flag_HideModule "MODULE")
- "behave as if MODULE has the hide attribute",
- Option [] ["show"] (ReqArg Flag_ShowModule "MODULE")
- "behave as if MODULE does not have the hide attribute",
- Option [] ["show-all"] (NoArg Flag_ShowAllModules)
- "behave as if not modules have the hide attribute",
- Option [] ["show-extensions"] (ReqArg Flag_ShowExtensions "MODULE")
- "behave as if MODULE has the show-extensions attribute",
- Option [] ["optghc"] (ReqArg Flag_OptGhc "OPTION")
- "option to be forwarded to GHC",
- Option [] ["ghc-version"] (NoArg Flag_GhcVersion)
- "output GHC version in numeric format",
- Option [] ["print-ghc-path"] (NoArg Flag_PrintGhcPath)
- "output path to GHC binary",
- Option [] ["print-ghc-libdir"] (NoArg Flag_PrintGhcLibDir)
- "output GHC lib dir",
- Option ['w'] ["no-warnings"] (NoArg Flag_NoWarnings) "turn off all warnings",
- Option [] ["no-tmp-comp-dir"] (NoArg Flag_NoTmpCompDir)
- "do not re-direct compilation output to a temporary directory",
- Option [] ["pretty-html"] (NoArg Flag_PrettyHtml)
- "generate html with newlines and indenting (for use with --html)",
- Option [] ["no-print-missing-docs"] (NoArg Flag_NoPrintMissingDocs)
- "don't print information about any undocumented entities",
- Option [] ["reexport"] (ReqArg Flag_Reexport "MOD")
- "reexport the module MOD, adding it to the index",
- Option [] ["package-name"] (ReqArg Flag_PackageName "NAME")
- "name of the package being documented",
- Option [] ["package-version"] (ReqArg Flag_PackageVersion "VERSION")
- "version of the package being documented in usual x.y.z.w format",
- Option [] ["since-qual"] (ReqArg Flag_SinceQualification "QUAL")
- "package qualification of @since, one of\n'always' (default) or 'only-external'",
- Option [] ["ignore-link-symbol"] (ReqArg Flag_IgnoreLinkSymbol "SYMBOL")
- "name of a symbol which does not trigger a warning in case of link issue",
- Option ['j'] [] (OptArg (\count -> Flag_ParCount (fmap read count)) "n")
- "load modules in parallel"
+ Option ['h'] ["html"] (NoArg Flag_Html) "output in HTML (XHTML 1.0)"
+ , Option ['O'] ["org"] (NoArg Flag_Org) "output in Org"
+ , Option [] ["latex"] (NoArg Flag_LaTeX) "use experimental LaTeX rendering"
+ , Option []
+ ["latex-style"]
+ (ReqArg Flag_LaTeXStyle "FILE")
+ "provide your own LaTeX style in FILE"
+ , Option [] ["mathjax"] (ReqArg Flag_Mathjax "URL") "URL FOR mathjax"
+ , Option ['U']
+ ["use-unicode"]
+ (NoArg Flag_UseUnicode)
+ "use Unicode in HTML output"
+ , Option
+ []
+ ["hoogle"]
+ (NoArg Flag_Hoogle)
+ "output for Hoogle; you may want --package-name and --package-version too"
+ , Option []
+ ["quickjump"]
+ (NoArg Flag_QuickJumpIndex)
+ "generate an index for interactive documentation navigation"
+ , Option
+ []
+ ["hyperlinked-source"]
+ (NoArg Flag_HyperlinkedSource)
+ "generate highlighted and hyperlinked source code (for use with --html)"
+ , Option []
+ ["source-css"]
+ (ReqArg Flag_SourceCss "FILE")
+ "use custom CSS file instead of default one in hyperlinked source"
+ , Option []
+ ["source-base"]
+ (ReqArg Flag_SourceBaseURL "URL")
+ "URL for a source code link on the contents\nand index pages"
+ , Option
+ ['s']
+ (if backwardsCompat then ["source", "source-module"] else ["source-module"])
+ (ReqArg Flag_SourceModuleURL "URL")
+ "URL for a source code link for each module\n(using the %{FILE} or %{MODULE} vars)"
+ , Option
+ []
+ ["source-entity"]
+ (ReqArg Flag_SourceEntityURL "URL")
+ "URL for a source code link for each entity\n(using the %{FILE}, %{MODULE}, %{NAME},\n%{KIND} or %{LINE} vars)"
+ , Option
+ []
+ ["source-entity-line"]
+ (ReqArg Flag_SourceLEntityURL "URL")
+ "URL for a source code link for each entity.\nUsed if name links are unavailable, eg. for TH splices."
+ , Option []
+ ["comments-base"]
+ (ReqArg Flag_WikiBaseURL "URL")
+ "URL for a comments link on the contents\nand index pages"
+ , Option
+ []
+ ["base-url"]
+ (ReqArg Flag_BaseURL "URL")
+ "Base URL for static assets (eg. css, javascript, json files etc.).\nWhen given statis assets will not be copied."
+ , Option
+ []
+ ["comments-module"]
+ (ReqArg Flag_WikiModuleURL "URL")
+ "URL for a comments link for each module\n(using the %{MODULE} var)"
+ , Option
+ []
+ ["comments-entity"]
+ (ReqArg Flag_WikiEntityURL "URL")
+ "URL for a comments link for each entity\n(using the %{FILE}, %{MODULE}, %{NAME},\n%{KIND} or %{LINE} vars)"
+ , Option ['c']
+ ["css", "theme"]
+ (ReqArg Flag_CSS "PATH")
+ "the CSS file or theme directory to use for HTML output"
+ , Option []
+ ["built-in-themes"]
+ (NoArg Flag_BuiltInThemes)
+ "include all the built-in haddock themes"
+ , Option ['p']
+ ["prologue"]
+ (ReqArg Flag_Prologue "FILE")
+ "file containing prologue text"
+ , Option ['t'] ["title"] (ReqArg Flag_Heading "TITLE") "page heading"
+ , Option
+ ['q']
+ ["qual"]
+ (ReqArg Flag_Qualification "QUAL")
+ "qualification of names, one of \n'none' (default), 'full', 'local'\n'relative' or 'aliased'"
+ , Option ['?'] ["help"] (NoArg Flag_Help) "display this help and exit"
+ , Option ['V']
+ ["version"]
+ (NoArg Flag_Version)
+ "output version information and exit"
+ , Option []
+ ["compatible-interface-versions"]
+ (NoArg Flag_CompatibleInterfaceVersions)
+ "output compatible interface file versions and exit"
+ , Option []
+ ["interface-version"]
+ (NoArg Flag_InterfaceVersion)
+ "output interface file version and exit"
+ , Option []
+ ["bypass-interface-version-check"]
+ (NoArg Flag_BypassInterfaceVersonCheck)
+ "bypass the interface file version check (dangerous)"
+ , Option ['v']
+ ["verbosity"]
+ (ReqArg Flag_Verbosity "VERBOSITY")
+ "set verbosity level"
+ , Option []
+ ["use-contents"]
+ (ReqArg Flag_UseContents "URL")
+ "use a separately-generated HTML contents page"
+ , Option []
+ ["gen-contents"]
+ (NoArg Flag_GenContents)
+ "generate an HTML contents from specified\ninterfaces"
+ , Option []
+ ["use-index"]
+ (ReqArg Flag_UseIndex "URL")
+ "use a separately-generated HTML index"
+ , Option []
+ ["gen-index"]
+ (NoArg Flag_GenIndex)
+ "generate an HTML index from specified\ninterfaces"
+ , Option []
+ ["ignore-all-exports"]
+ (NoArg Flag_IgnoreAllExports)
+ "behave as if all modules have the\nignore-exports attribute"
+ , Option []
+ ["hide"]
+ (ReqArg Flag_HideModule "MODULE")
+ "behave as if MODULE has the hide attribute"
+ , Option []
+ ["show"]
+ (ReqArg Flag_ShowModule "MODULE")
+ "behave as if MODULE does not have the hide attribute"
+ , Option []
+ ["show-all"]
+ (NoArg Flag_ShowAllModules)
+ "behave as if not modules have the hide attribute"
+ , Option []
+ ["show-extensions"]
+ (ReqArg Flag_ShowExtensions "MODULE")
+ "behave as if MODULE has the show-extensions attribute"
+ , Option []
+ ["optghc"]
+ (ReqArg Flag_OptGhc "OPTION")
+ "option to be forwarded to GHC"
+ , Option []
+ ["ghc-version"]
+ (NoArg Flag_GhcVersion)
+ "output GHC version in numeric format"
+ , Option []
+ ["print-ghc-path"]
+ (NoArg Flag_PrintGhcPath)
+ "output path to GHC binary"
+ , Option []
+ ["print-ghc-libdir"]
+ (NoArg Flag_PrintGhcLibDir)
+ "output GHC lib dir"
+ , Option ['w'] ["no-warnings"] (NoArg Flag_NoWarnings) "turn off all warnings"
+ , Option []
+ ["no-tmp-comp-dir"]
+ (NoArg Flag_NoTmpCompDir)
+ "do not re-direct compilation output to a temporary directory"
+ , Option []
+ ["pretty-html"]
+ (NoArg Flag_PrettyHtml)
+ "generate html with newlines and indenting (for use with --html)"
+ , Option []
+ ["no-print-missing-docs"]
+ (NoArg Flag_NoPrintMissingDocs)
+ "don't print information about any undocumented entities"
+ , Option []
+ ["reexport"]
+ (ReqArg Flag_Reexport "MOD")
+ "reexport the module MOD, adding it to the index"
+ , Option []
+ ["package-name"]
+ (ReqArg Flag_PackageName "NAME")
+ "name of the package being documented"
+ , Option []
+ ["package-version"]
+ (ReqArg Flag_PackageVersion "VERSION")
+ "version of the package being documented in usual x.y.z.w format"
+ , Option
+ []
+ ["since-qual"]
+ (ReqArg Flag_SinceQualification "QUAL")
+ "package qualification of @since, one of\n'always' (default) or 'only-external'"
+ , Option
+ []
+ ["ignore-link-symbol"]
+ (ReqArg Flag_IgnoreLinkSymbol "SYMBOL")
+ "name of a symbol which does not trigger a warning in case of link issue"
+ , Option ['j']
+ []
+ (OptArg (\count -> Flag_ParCount (fmap read count)) "n")
+ "load modules in parallel"
]
@@ -240,23 +355,22 @@ getUsage :: IO String
getUsage = do
prog <- getProgramName
return $ usageInfo (usageHeader prog) (options False)
- where
- usageHeader :: String -> String
- usageHeader prog = "Usage: " ++ prog ++ " [OPTION...] file...\n"
+ where
+ usageHeader :: String -> String
+ usageHeader prog = "Usage: " ++ prog ++ " [OPTION...] file...\n"
parseHaddockOpts :: [String] -> IO ([Flag], [String])
-parseHaddockOpts params =
- case getOpt Permute (options True) params of
- (flags, args, []) -> return (flags, args)
- (_, _, errors) -> do
- usage <- getUsage
- throwE (concat errors ++ usage)
+parseHaddockOpts params = case getOpt Permute (options True) params of
+ (flags, args, [] ) -> return (flags, args)
+ (_ , _ , errors) -> do
+ usage <- getUsage
+ throwE (concat errors ++ usage)
optPackageVersion :: [Flag] -> Maybe Data.Version.Version
optPackageVersion flags =
let ver = optLast [ v | Flag_PackageVersion v <- flags ]
- in ver >>= fmap fst . optLast . RP.readP_to_S parseVersion
+ in ver >>= fmap fst . optLast . RP.readP_to_S parseVersion
optPackageName :: [Flag] -> Maybe PackageName
optPackageName flags =
@@ -264,17 +378,15 @@ optPackageName flags =
optTitle :: [Flag] -> Maybe String
-optTitle flags =
- case [str | Flag_Heading str <- flags] of
- [] -> Nothing
- (t:_) -> Just t
+optTitle flags = case [ str | Flag_Heading str <- flags ] of
+ [] -> Nothing
+ (t : _) -> Just t
outputDir :: [Flag] -> FilePath
-outputDir flags =
- case [ path | Flag_OutputDir path <- flags ] of
- [] -> "."
- paths -> last paths
+outputDir flags = case [ path | Flag_OutputDir path <- flags ] of
+ [] -> "."
+ paths -> last paths
optContentsUrl :: [Flag] -> Maybe String
@@ -291,23 +403,26 @@ optCssFile flags = optLast [ str | Flag_CSS str <- flags ]
optSourceCssFile :: [Flag] -> Maybe FilePath
optSourceCssFile flags = optLast [ str | Flag_SourceCss str <- flags ]
-sourceUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String, Maybe String)
+sourceUrls
+ :: [Flag] -> (Maybe String, Maybe String, Maybe String, Maybe String)
sourceUrls flags =
- (optLast [str | Flag_SourceBaseURL str <- flags]
- ,optLast [str | Flag_SourceModuleURL str <- flags]
- ,optLast [str | Flag_SourceEntityURL str <- flags]
- ,optLast [str | Flag_SourceLEntityURL str <- flags])
+ ( optLast [ str | Flag_SourceBaseURL str <- flags ]
+ , optLast [ str | Flag_SourceModuleURL str <- flags ]
+ , optLast [ str | Flag_SourceEntityURL str <- flags ]
+ , optLast [ str | Flag_SourceLEntityURL str <- flags ]
+ )
wikiUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String)
wikiUrls flags =
- (optLast [str | Flag_WikiBaseURL str <- flags]
- ,optLast [str | Flag_WikiModuleURL str <- flags]
- ,optLast [str | Flag_WikiEntityURL str <- flags])
+ ( optLast [ str | Flag_WikiBaseURL str <- flags ]
+ , optLast [ str | Flag_WikiModuleURL str <- flags ]
+ , optLast [ str | Flag_WikiEntityURL str <- flags ]
+ )
baseUrl :: [Flag] -> Maybe String
-baseUrl flags = optLast [str | Flag_BaseURL str <- flags]
+baseUrl flags = optLast [ str | Flag_BaseURL str <- flags ]
optDumpInterfaceFile :: [Flag] -> Maybe FilePath
optDumpInterfaceFile flags = optLast [ str | Flag_DumpInterface str <- flags ]
@@ -327,31 +442,30 @@ optParCount flags = optLast [ n | Flag_ParCount n <- flags ]
qualification :: [Flag] -> Either String QualOption
qualification flags =
case map (map Char.toLower) [ str | Flag_Qualification str <- flags ] of
- [] -> Right OptNoQual
- ["none"] -> Right OptNoQual
- ["full"] -> Right OptFullQual
- ["local"] -> Right OptLocalQual
- ["relative"] -> Right OptRelativeQual
- ["aliased"] -> Right OptAliasedQual
- [arg] -> Left $ "unknown qualification type " ++ show arg
- _:_ -> Left "qualification option given multiple times"
+ [] -> Right OptNoQual
+ [ "none" ] -> Right OptNoQual
+ [ "full" ] -> Right OptFullQual
+ [ "local" ] -> Right OptLocalQual
+ [ "relative"] -> Right OptRelativeQual
+ [ "aliased" ] -> Right OptAliasedQual
+ [ arg ] -> Left $ "unknown qualification type " ++ show arg
+ _ : _ -> Left "qualification option given multiple times"
sinceQualification :: [Flag] -> Either String SinceQual
sinceQualification flags =
case map (map Char.toLower) [ str | Flag_SinceQualification str <- flags ] of
- [] -> Right Always
- ["always"] -> Right Always
- ["external"] -> Right External
- [arg] -> Left $ "unknown since-qualification type " ++ show arg
- _:_ -> Left "since-qualification option given multiple times"
+ [] -> Right Always
+ [ "always" ] -> Right Always
+ [ "external"] -> Right External
+ [ arg ] -> Left $ "unknown since-qualification type " ++ show arg
+ _ : _ -> Left "since-qualification option given multiple times"
verbosity :: [Flag] -> Verbosity
-verbosity flags =
- case [ str | Flag_Verbosity str <- flags ] of
- [] -> Normal
- x:_ -> case parseVerbosity x of
- Left e -> throwE e
- Right v -> v
+verbosity flags = case [ str | Flag_Verbosity str <- flags ] of
+ [] -> Normal
+ x : _ -> case parseVerbosity x of
+ Left e -> throwE e
+ Right v -> v
ignoredSymbols :: [Flag] -> [String]
ignoredSymbols flags = [ symbol | Flag_IgnoreLinkSymbol symbol <- flags ]
@@ -367,26 +481,21 @@ data Visibility = Visible | Hidden
readIfaceArgs :: [Flag] -> [(DocPaths, Visibility, FilePath)]
readIfaceArgs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ]
- where
- parseIfaceOption :: String -> (DocPaths, Visibility, FilePath)
- parseIfaceOption str =
- case break (==',') str of
- (fpath, ',':rest) ->
- case break (==',') rest of
- (src, ',':rest') ->
- let src' = case src of
- "" -> Nothing
- _ -> Just src
- in
- case break (==',') rest' of
- (visibility, ',':file) | visibility == "hidden" ->
- ((fpath, src'), Hidden, file)
- | otherwise ->
- ((fpath, src'), Visible, file)
- (file, _) ->
- ((fpath, src'), Visible, file)
- (file, _) -> ((fpath, Nothing), Visible, file)
- (file, _) -> (("", Nothing), Visible, file)
+ where
+ parseIfaceOption :: String -> (DocPaths, Visibility, FilePath)
+ parseIfaceOption str = case break (== ',') str of
+ (fpath, ',' : rest) -> case break (== ',') rest of
+ (src, ',' : rest') ->
+ let src' = case src of
+ "" -> Nothing
+ _ -> Just src
+ in case break (== ',') rest' of
+ (visibility, ',' : file)
+ | visibility == "hidden" -> ((fpath, src'), Hidden, file)
+ | otherwise -> ((fpath, src'), Visible, file)
+ (file, _) -> ((fpath, src'), Visible, file)
+ (file, _) -> ((fpath, Nothing), Visible, file)
+ (file, _) -> (("", Nothing), Visible, file)
-- | Like 'listToMaybe' but returns the last element instead of the first.
@@ -401,16 +510,16 @@ optLast xs = Just (last xs)
--
-- The @--package-name@ and @--package-version@ Haddock flags allow the user to
-- specify this information manually and it is returned here if present.
-modulePackageInfo :: UnitState
- -> [Flag] -- ^ Haddock flags are checked as they may contain
+modulePackageInfo
+ :: UnitState
+ -> [Flag] -- ^ Haddock flags are checked as they may contain
-- the package name or version provided by the user
-- which we prioritise
- -> Maybe Module
- -> (Maybe PackageName, Maybe Data.Version.Version)
+ -> Maybe Module
+ -> (Maybe PackageName, Maybe Data.Version.Version)
modulePackageInfo _unit_state _flags Nothing = (Nothing, Nothing)
modulePackageInfo unit_state flags (Just modu) =
- ( optPackageName flags <|> fmap unitPackageName pkgDb
+ ( optPackageName flags <|> fmap unitPackageName pkgDb
, optPackageVersion flags <|> fmap unitPackageVersion pkgDb
)
- where
- pkgDb = lookupUnit unit_state (moduleUnit modu)
+ where pkgDb = lookupUnit unit_state (moduleUnit modu)
diff --git a/haddock-api/src/Haddock/Version.hs b/haddock-api/src/Haddock/Version.hs
index 4e9a581a..b2eb7031 100644
--- a/haddock-api/src/Haddock/Version.hs
+++ b/haddock-api/src/Haddock/Version.hs
@@ -16,7 +16,7 @@ module Haddock.Version (
#ifdef IN_GHC_TREE
import Paths_haddock ( version )
#else
-import Paths_haddock_api ( version )
+import Paths_haddorg_api ( version )
#endif
import Data.Version ( showVersion )
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-15 14:18:46 +0000