+++ /dev/null
-.cabal-sandbox/
-cabal.sandbox.config
-dist/
+++ /dev/null
- GNU GENERAL PUBLIC LICENSE
- Version 3, 29 June 2007
-
- Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
- Everyone is permitted to copy and distribute verbatim copies
- of this license document, but changing it is not allowed.
-
- Preamble
-
- The GNU General Public License is a free, copyleft license for
-software and other kinds of works.
-
- The licenses for most software and other practical works are designed
-to take away your freedom to share and change the works. By contrast,
-the GNU General Public License is 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. We, the Free Software Foundation, use the
-GNU General Public License for most of our software; it applies also to
-any other work released this way by its authors. You can apply it to
-your programs, too.
-
- 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.
-
- To protect your rights, we need to prevent others from denying you
-these rights or asking you to surrender the rights. Therefore, you have
-certain responsibilities if you distribute copies of the software, or if
-you modify it: responsibilities to respect the freedom of others.
-
- For example, if you distribute copies of such a program, whether
-gratis or for a fee, you must pass on to the recipients the same
-freedoms that you received. You must make sure that they, too, receive
-or can get the source code. And you must show them these terms so they
-know their rights.
-
- Developers that use the GNU GPL protect your rights with two steps:
-(1) assert copyright on the software, and (2) offer you this License
-giving you legal permission to copy, distribute and/or modify it.
-
- For the developers' and authors' protection, the GPL clearly explains
-that there is no warranty for this free software. For both users' and
-authors' sake, the GPL requires that modified versions be marked as
-changed, so that their problems will not be attributed erroneously to
-authors of previous versions.
-
- Some devices are designed to deny users access to install or run
-modified versions of the software inside them, although the manufacturer
-can do so. This is fundamentally incompatible with the aim of
-protecting users' freedom to change the software. The systematic
-pattern of such abuse occurs in the area of products for individuals to
-use, which is precisely where it is most unacceptable. Therefore, we
-have designed this version of the GPL to prohibit the practice for those
-products. If such problems arise substantially in other domains, we
-stand ready to extend this provision to those domains in future versions
-of the GPL, as needed to protect the freedom of users.
-
- Finally, every program is threatened constantly by software patents.
-States should not allow patents to restrict development and use of
-software on general-purpose computers, but in those that do, we wish to
-avoid the special danger that patents applied to a free program could
-make it effectively proprietary. To prevent this, the GPL assures that
-patents cannot be used to render the program non-free.
-
- 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 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. Use with the GNU Affero General Public License.
-
- 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 Affero 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 special requirements of the GNU Affero General Public License,
-section 13, concerning interaction through a network will apply to the
-combination as such.
-
- 14. Revised Versions of this License.
-
- The Free Software Foundation may publish revised and/or new versions of
-the GNU 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 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 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 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 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 General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-Also add information on how to contact you by electronic and paper mail.
-
- If the program does terminal interaction, make it output a short
-notice like this when it starts in an interactive mode:
-
- <program> Copyright (C) <year> <name of author>
- This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
- This is free software, and you are welcome to redistribute it
- under certain conditions; type `show c' for details.
-
-The hypothetical commands `show w' and `show c' should show the appropriate
-parts of the General Public License. Of course, your program's commands
-might be different; for a GUI interface, you would use an "about box".
-
- 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 GPL, see
-<http://www.gnu.org/licenses/>.
-
- The GNU General Public License does not permit incorporating your program
-into proprietary programs. If your program is a subroutine library, you
-may consider it more useful to permit linking proprietary applications with
-the library. If this is what you want to do, use the GNU Lesser General
-Public License instead of this License. But first, please read
-<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+++ /dev/null
-{-# LANGUAGE TupleSections #-}
-module Hcompta.CLI.Args where
-
-import Control.Monad (Monad(..))
-import Data.Function ((.))
-import qualified Data.List as List
-import Data.Monoid ((<>))
-import Data.Functor ((<$>))
-import Data.String (String)
-import qualified Data.Text.Lazy as TL
-import System.Console.GetOpt
- ( getOpt
- , ArgOrder(..)
- , OptDescr(..)
- )
-import System.IO (IO)
-import qualified Text.WalderLeijen.ANSI.Text as W
-
-import Hcompta.CLI.Context (Context)
-import qualified Hcompta.CLI.Write as Write
-
-type Options context
- = [OptDescr (context -> IO context)]
-
-parse
- :: Context
- -> (Context -> IO String)
- -> (Context -> Options c)
- -> (c, [String])
- -> IO (c, [String])
-parse c usage options (ctx, args) =
- case getOpt RequireOrder (options c) args of
- (parsers, cmds, []) ->
- (, cmds) <$>
- List.foldl' (>>=) (return ctx) parsers
- (_, _, errs) ->
- usage c >>=
- Write.fatal c .
- (W.vsep (W.text . TL.pack <$> errs) <>) .
- W.text . TL.pack
+++ /dev/null
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TupleSections #-}
-module Hcompta.CLI.Command where
-
-import Control.Monad (Monad(..))
-import Data.Bool
-import Data.List ((++))
-import Data.Maybe (Maybe(..), fromMaybe)
-import Data.Monoid ((<>))
-import Data.Ord (Ord(..))
-import Data.String (String)
-import qualified Data.Text.Lazy as TL
-import Prelude (($), (.), Bounded(..), Enum(..), IO, unlines)
-import System.Console.GetOpt
- ( ArgDescr(..)
- , OptDescr(..)
- , usageInfo )
-import System.Environment (getProgName)
-import System.Exit (exitSuccess)
-import qualified System.IO as IO
-import qualified Text.WalderLeijen.ANSI.Text as W
-
-import qualified Hcompta.CLI.Args as Args
--- import qualified Hcompta.CLI.Command.Balance as Command.Balance
--- import qualified Hcompta.CLI.Command.GL as Command.GL
--- import qualified Hcompta.CLI.Command.Journal as Command.Journal
-import qualified Hcompta.CLI.Command.Journals as Command.Journals
--- import qualified Hcompta.CLI.Command.Stats as Command.Stats
--- import qualified Hcompta.CLI.Command.Tags as Command.Tags
-import qualified Hcompta.CLI.Context as C
-import qualified Hcompta.CLI.Lang as Lang
-import qualified Hcompta.CLI.Write as Write
-
-usage :: C.Context -> IO String
-usage c = do
- bin <- getProgName
- return $ unlines
- [ C.translate c Lang.Section_Syntax
- , " "++bin++" "++C.translate c Lang.Help_Synopsis
- , ""
- , usageInfo (C.translate c Lang.Section_Options) (options c)
- , C.translate c Lang.Section_Commands
- , " [bal|balance] "++C.translate c Lang.Help_Command_Balance
- , " [gl|general_ledger] "++C.translate c Lang.Help_Command_General_Ledger
- , " [j|journal] "++C.translate c Lang.Help_Command_Journal
- , " [js|journals] "++C.translate c Lang.Help_Command_Journals
- , " stats "++C.translate c Lang.Help_Command_Stats
- , " tags "++C.translate c Lang.Help_Command_Tags
- ]
-
-options :: C.Context -> Args.Options C.Context
-options ctx =
- [ Option "h" ["help"]
- (NoArg (\_opts -> do
- usage ctx >>= IO.hPutStr IO.stderr
- exitSuccess)) $
- C.translate ctx Lang.Help_Option_Help
- , Option "v" ["verbosity"]
- (OptArg (\arg c ->
- case arg of
- Nothing ->
- case C.verbosity c of
- v | v < maxBound -> return $ c{C.verbosity=succ v}
- _ -> return $ c
- Just "error" -> return $ c{C.verbosity=C.Verbosity_Error}
- Just "warn" -> return $ c{C.verbosity=C.Verbosity_Warn}
- Just "info" -> return $ c{C.verbosity=C.Verbosity_Info}
- Just "debug" -> return $ c{C.verbosity=C.Verbosity_Debug}
- Just _ -> Write.fatal c Lang.Error_Option_Verbosity)
- "error|warn|info|debug") $
- C.translate ctx Lang.Help_Option_Verbosity
- , Option "" ["color"]
- (OptArg (\arg c -> do
- color <- case arg of
- Nothing -> return $ Just True
- Just "yes" -> return $ Just True
- Just "no" -> return $ Just False
- Just "auto" -> return $ Nothing
- Just _ -> Write.fatal c Lang.Error_Option_Color
- return $ c{C.color})
- "[auto|yes|no]") $
- C.translate ctx Lang.Help_Option_Color
- , Option "" ["lang"]
- (ReqArg (\lang c ->
- return $ c{C.lang =
- fromMaybe (C.lang c) $
- Lang.from_Strings [lang]
- })
- "[xx|xx-XX]") $
- C.translate ctx Lang.Help_Option_Lang
- ]
-
-run :: C.Context -> String -> [String] -> IO ()
-run c cmd args =
- case cmd of
- -- "bal" -> Command.Balance.run c args
- -- "balance" -> Command.Balance.run c args
- -- "gl" -> Command.GL.run c args
- -- "general_ledger" -> Command.GL.run c args
- -- "j" -> Command.Journal.run c args
- -- "journal" -> Command.Journal.run c args
- -- "js" -> Command.Journals.run c args
- "journals" -> Command.Journals.run c args
- -- "stats" -> Command.Stats.run c args
- -- "tags" -> Command.Tags.run c args
- _ -> usage c >>= Write.fatal c .
- ((C.translate c (Lang.Error_Unkown_command cmd) <> W.line) <>) .
- W.text . TL.pack
+++ /dev/null
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.CLI.Command.Balance where
-
-import Control.Applicative ((<*), Const(..), Applicative(..))
-import Control.Arrow (first, (+++), (&&&), (***))
-import Control.DeepSeq (NFData)
-import Control.Monad (Monad(..), liftM, mapM)
-import Control.Monad.IO.Class (liftIO)
-import Data.Bool
-import Data.Data
-import Data.Decimal (Decimal)
-import Data.Either (Either(..), partitionEithers)
-import Data.Eq (Eq(..))
-import Data.Foldable (Foldable)
-import qualified Data.Foldable as Foldable
-import Data.Function (($), (.), const, on)
-import Data.Functor (Functor(..), (<$>))
-import qualified Data.List as List
--- import Data.List.NonEmpty (NonEmpty(..))
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Map
-import Data.Maybe (Maybe(..))
-import Data.Monoid (Monoid(..), (<>))
-import Data.Ord (Ord(..), Ordering(..))
-import qualified Data.Strict.Maybe as Strict
-import Data.String (String)
-import Data.Text (Text)
-import qualified Data.Time.Clock as Time
-import Data.TreeMap.Strict (TreeMap)
-import qualified Data.TreeMap.Strict as TreeMap
-import Data.Tuple (fst, snd)
-import Prelude (Bounded(..), Num(..), unlines, zipWith)
-import Data.Function (id, flip)
-import System.Console.GetOpt
- ( ArgDescr(..)
- , OptDescr(..)
- , usageInfo
- )
-import qualified System.Environment as Env
-import System.Exit (exitSuccess)
-import System.IO (IO, FilePath)
-import qualified System.IO as IO
-import qualified Text.Parsec
-import Text.Show (Show(..))
-import Text.WalderLeijen.ANSI.Text (ToDoc(..))
-import qualified Text.WalderLeijen.ANSI.Text as W
-
-import qualified Hcompta as H
-import qualified Hcompta.Lib.Strict as Strict
-
-import qualified Hcompta.CLI.Args as Args
-import qualified Hcompta.CLI.Context as C
-import qualified Hcompta.CLI.Env as CLI.Env
-import Hcompta.CLI.Format (Format(..), Formats)
-import qualified Hcompta.CLI.Format as Format
-import Hcompta.CLI.Format.JCC ()
-import Hcompta.CLI.Format.Ledger ()
-import qualified Hcompta.CLI.Lang as Lang
-import qualified Hcompta.CLI.Lib.Leijen.Table as Leijen.Table
-import qualified Hcompta.CLI.Write as Write
-import qualified Hcompta.JCC as JCC
-import qualified Hcompta.Ledger as Ledger
-
-import qualified Text.Parsec.Error.Custom as R
-
--- type Sum = (Ledger.Unit, H.Polarized Ledger.Quantity)
-
-data Context
- = Context
- { {-ctx_filter_transaction :: forall t.
- ( Filter.Transaction t
- , Filter.Amount_Quantity
- (Posting.Posting_Amount
- (Filter.Transaction_Posting t))
- ~ Filter.Amount.Quantity
- ) => Filter.Simplified
- (Filter.Filter_Bool
- (Filter.Filter_Transaction t))
- , ctx_filter_balance :: forall b.
- ( Filter.Balance b
- , Filter.Amount_Quantity
- (Filter.Balance_Amount b)
- ~ Filter.Amount.Quantity
- ) => Filter.Simplified
- (Filter.Filter_Bool
- (Filter.Filter_Balance b))
- -- , ctx_filter_posting :: CLI.Format.Filter_Posting
- ,-} ctx_heritage :: Bool
- , ctx_input :: [FilePath]
- , ctx_input_format :: Formats
- , ctx_output :: [(Write.Mode, FilePath)]
- , ctx_output_format :: (Maybe Formats, Output_Format)
- , ctx_reduce_date :: Bool
- , ctx_redundant :: Bool
- , ctx_total_by_unit :: Bool
- , ctx_account_equilibrium :: (JCC.Account, JCC.Account)
- } -- deriving (Show)
-
-data Output_Format
- = Output_Format_Table
- | Output_Format_Transaction Lang.Exercise_OC
- deriving (Eq, Show)
-
-context :: C.Context -> Context
-context c =
- Context
- { -- ctx_filter_transaction = Filter.Simplified $ Right True
- -- , ctx_filter_balance = Filter.Simplified $ Right True
- -- , ctx_filter_posting = mempty
- ctx_heritage = True
- , ctx_input = []
- , ctx_input_format = mempty
- , ctx_output = []
- , ctx_output_format = (Nothing, Output_Format_Table)
- , ctx_reduce_date = True
- , ctx_redundant = False
- , ctx_total_by_unit = True
- , ctx_account_equilibrium =
- let e = C.translate c Lang.Account_Equilibrium
- in (e, e)
- }
-
-usage :: C.Context -> IO String
-usage c = do
- bin <- Env.getProgName
- return $ unlines $
- [ C.translate c Lang.Section_Description
- , " "<>C.translate c Lang.Help_Command_Balance
- , ""
- , C.translate c Lang.Section_Syntax
- , " "<>bin<>" balance ["<>C.translate c Lang.Type_Option<>"] [...]"<>
- " ["<>C.translate c Lang.Type_File_Journal<>"] [...]"
- , ""
- , usageInfo (C.translate c Lang.Section_Options) (options c)
- ]
-
-options :: C.Context -> Args.Options Context
-options c =
- [ {-Option "b" ["filter-balance"]
- (ReqArg (\s ctx -> do
- filter <-
- R.runParserT_with_Error
- Filter.Read.filter_balance
- Filter.Read.context "" s
- case filter of
- Left (ko::[R.Error Filter.Read.Error]) -> Write.fatal c ko
- Right flt ->
- return $
- ctx{ctx_filter_balance =
- Filter.and (ctx_filter_balance ctx) $
- (Filter.simplify $
- Filter.Read.get_Forall_Filter_Balance_Decimal <$> flt)
- }) $
- C.translate c Lang.Type_Filter_Balance) $
- C.translate c Lang.Help_Option_Filter_Balance
- -}
- {-, Option "p" ["filter-posting"]
- (ReqArg (\s ctx -> do
- read <- liftIO $ Filter.Read.read Filter.Read.filter_posting s
- case read of
- Left ko -> Write.fatal c ko
- Right filter -> return $
- ctx{ctx_filter_posting =
- (ctx_filter_posting ctx <>) $
- CLI.Format.All
- (Filter.simplify $ Filter.Read.get_Forall_Filter_Posting_Decimal <$> filter)
- (Filter.simplify $ Filter.Read.get_Forall_Filter_Posting_Decimal <$> filter)
- }) $
- C.translate c Lang.Type_Filter_Posting) $
- C.translate c Lang.Help_Option_Filter_Posting
- -}
- {-, Option "t" ["filter-transaction"]
- (ReqArg (\s ctx -> do
- filter <-
- R.runParserT_with_Error
- Filter.Read.filter_transaction
- Filter.Read.context "" s
- case filter of
- Left ko -> Write.fatal c ko
- Right flt ->
- return $
- ctx{ctx_filter_transaction =
- Filter.and (ctx_filter_transaction ctx) $
- (Filter.simplify $
- Filter.Read.get_Forall_Filter_Transaction_Decimal <$> flt)
- }) $
- C.translate c Lang.Type_Filter_Transaction) $
- C.translate c Lang.Help_Option_Filter_Transaction
- ,-} Option "h" ["help"]
- (NoArg (\_ctx -> do
- usage c >>= IO.hPutStr IO.stderr
- exitSuccess)) $
- C.translate c Lang.Help_Option_Help
- , Option "i" ["input"]
- (ReqArg (\s ctx -> do
- return $ ctx{ctx_input=s:ctx_input ctx}) $
- C.translate c Lang.Type_File_Journal) $
- C.translate c Lang.Help_Option_Input
- , Option "f" ["input-format"]
- (OptArg (\arg ctx -> do
- ctx_input_format <- case arg of
- Nothing -> return $ Format_JCC ()
- Just "jcc" -> return $ Format_JCC ()
- Just "ledger" -> return $ Format_Ledger ()
- Just _ -> Write.fatal c $
- W.text "--input-format option expects \"jcc\", or \"ledger\" as value"
- return $ ctx{ctx_input_format})
- "[jcc|ledger]")
- "input format"
- , Option "o" ["output"]
- (ReqArg (\s ctx -> do
- return $ ctx{ctx_output=(Write.Mode_Append, s):ctx_output ctx}) $
- C.translate c Lang.Type_File) $
- C.translate c Lang.Help_Option_Output
- , Option "O" ["overwrite"]
- (ReqArg (\s ctx -> do
- return $ ctx{ctx_output=(Write.Mode_Over, s):ctx_output ctx}) $
- C.translate c Lang.Type_File) $
- C.translate c Lang.Help_Option_Overwrite
- {- NOTE: not used so far.
- , Option "" ["reduce-date"]
- (OptArg (\arg ctx -> do
- ctx_reduce_date <- case arg of
- Nothing -> return $ True
- Just "yes" -> return $ True
- Just "no" -> return $ False
- Just _ -> Write.fatal c $
- W.text "--reduce-date option expects \"yes\", or \"no\" as value"
- return $ ctx{ctx_reduce_date})
- "[yes|no]")
- "use advanced date reducer to speed up filtering"
- -}
- , Option "" ["redundant"]
- (OptArg (\arg ctx -> do
- ctx_redundant <- case arg of
- Nothing -> return $ True
- Just "yes" -> return $ True
- Just "no" -> return $ False
- Just _ -> Write.fatal c Lang.Error_Option_Balance_Redundant
- return $ ctx{ctx_redundant})
- "[no|yes]") $
- C.translate c Lang.Help_Option_Balance_Redundant
- , Option "" ["heritage"]
- (OptArg (\arg ctx -> do
- ctx_heritage <- case arg of
- Nothing -> return $ True
- Just "yes" -> return $ True
- Just "no" -> return $ False
- Just _ -> Write.fatal c Lang.Error_Option_Balance_Heritage
- return $ ctx{ctx_heritage})
- "[yes|no]") $
- C.translate c Lang.Help_Option_Balance_Heritage
- , Option "" ["total"]
- (OptArg (\arg ctx -> do
- ctx_total_by_unit <- case arg of
- Nothing -> return $ True
- Just "yes" -> return $ True
- Just "no" -> return $ False
- Just _ -> Write.fatal c Lang.Error_Option_Balance_Total
- return $ ctx{ctx_total_by_unit})
- "[yes|no]") $
- C.translate c Lang.Help_Option_Balance_Total
- , Option "F" ["output-format"]
- (ReqArg (\arg ctx -> do
- ctx_output_format <- case arg of
- "table" -> return $ (Nothing , Output_Format_Table)
- "table.jcc" -> return $ (Just $ Format_JCC (), Output_Format_Table)
- "table.ledger" -> return $ (Just $ Format_Ledger (), Output_Format_Table)
- "open" -> return $ (Nothing , Output_Format_Transaction Lang.Exercise_Opening)
- "open.jcc" -> return $ (Just $ Format_JCC (), Output_Format_Transaction Lang.Exercise_Opening)
- "open.ledger" -> return $ (Just $ Format_Ledger (), Output_Format_Transaction Lang.Exercise_Opening)
- "close" -> return $ (Nothing , Output_Format_Transaction Lang.Exercise_Closing)
- "close.jcc" -> return $ (Just $ Format_JCC (), Output_Format_Transaction Lang.Exercise_Closing)
- "close.ledger" -> return $ (Just $ Format_Ledger (), Output_Format_Transaction Lang.Exercise_Closing)
- _ -> Write.fatal c Lang.Error_Option_Balance_Format
- return $ ctx{ctx_output_format})
- "[table|close|open][.jcc|.ledger]") $
- C.translate c Lang.Help_Option_Balance_Format
- , Option "" ["eq"]
- (ReqArg (\arg ctx -> do
- ctx_account_equilibrium <-
- fmap (\e -> (e, e)) $
- case Text.Parsec.runParser
- (Ledger.read_account <* Text.Parsec.eof)
- () "" arg of
- Right acct -> return acct
- _ -> Write.fatal c Lang.Error_Option_Equilibrium
- return $ ctx{ctx_account_equilibrium}) $
- C.translate c Lang.Type_Account) $
- C.translate c Lang.Help_Option_Equilibrium
- , Option "" ["eq-credit"]
- (ReqArg (\arg ctx -> do
- ctx_account_equilibrium <-
- fmap (\e -> (fst $ ctx_account_equilibrium ctx, e)) $
- case Text.Parsec.runParser
- (Ledger.read_account <* Text.Parsec.eof)
- () "" arg of
- Right acct -> return acct
- _ -> Write.fatal c Lang.Error_Option_Equilibrium_Credit
- return $ ctx{ctx_account_equilibrium}) $
- C.translate c Lang.Type_Account) $
- C.translate c Lang.Help_Option_Equilibrium_Credit
- , Option "" ["eq-debit"]
- (ReqArg (\arg ctx -> do
- ctx_account_equilibrium <-
- fmap (\e -> (e, snd $ ctx_account_equilibrium ctx)) $
- case Text.Parsec.runParser
- (Ledger.read_account <* Text.Parsec.eof)
- () "" arg of
- Right acct -> return acct
- _ -> Write.fatal c Lang.Error_Option_Equilibrium_Debit
- return $ ctx{ctx_account_equilibrium}) $
- C.translate c Lang.Type_Account) $
- C.translate c Lang.Help_Option_Equilibrium_Debit
- ]
-
-run :: C.Context -> [String] -> IO ()
-run c args = do
- (ctx, inputs) <-
- first (\x ->
- case ctx_output x of
- [] -> x{ctx_output=[(Write.Mode_Append, "-")]}
- _ -> x) <$>
- Args.parse c usage options (context c, args)
- input_paths <- CLI.Env.paths c $ ctx_input ctx <> inputs
- read_journals <- mapM (liftIO . journal_read ctx) input_paths
- case partitionEithers read_journals of
- (errs@(_:_), _journals) -> Write.fatals c errs
- ([], (journals::[Forall_Journal_Balance_by_Account])) -> do
- let bal_by_account =
- mconcat $
- fmap Format.journal_flatten $
- case fst $ ctx_output_format ctx of
- Just f -> Format.journal_empty f:journals
- Nothing -> journals
- now <- H.date_epoch
- with_color <- Write.with_color c IO.stdout
- W.displayIO IO.stdout $
- W.renderPretty with_color 1.0 maxBound $
- case snd $ ctx_output_format ctx of
- Output_Format_Table ->
- toDoc () $ Leijen.Table.table_of (c, ctx) bal_by_account
- Output_Format_Transaction oc ->
- journal_equilibrium_transaction
- (Const bal_by_account::Const Forall_Journal_Balance_by_Account ())
- c ctx oc now
- {-
- Write.debug c $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
- Write.debug c $ "filter: posting: " ++ show (ctx_filter_posting ctx)
- Write.debug c $ "filter: balance: " ++ show (ctx_filter_balance ctx)
- let sty = Write.style { Write.style_pretty = True }
- -}
-
-instance Leijen.Table.Table_of (C.Context, Context) Forall_Journal_Balance_by_Account where
- table_of (c, ctx) bal_by_account =
- let lang = C.lang c in
- let (rows_by_account, rows_by_unit) =
- case ctx_heritage ctx of
- True -> rows_of_balance_by_account $ expand bal_by_account
- False -> rows_of_balance_by_account bal_by_account in
- zipWith id
- [ Leijen.Table.column (Lang.translate lang Lang.Title_Debit) Leijen.Table.Align_Right
- , Leijen.Table.column (Lang.translate lang Lang.Title_Credit) Leijen.Table.Align_Right
- , Leijen.Table.column (Lang.translate lang Lang.Title_Balance) Leijen.Table.Align_Right
- , Leijen.Table.column (Lang.translate lang Lang.Title_Account) Leijen.Table.Align_Left
- ] $
- rows_by_account $
- (if ctx_total_by_unit ctx
- then zipWith (:)
- [ Leijen.Table.Cell_Line '=' 0
- , Leijen.Table.Cell_Line '=' 0
- , Leijen.Table.Cell_Line '=' 0
- , Leijen.Table.Cell_Line ' ' 0
- ] . rows_by_unit
- else id) $
- List.repeat []
- where
- expand
- :: Forall_Journal_Balance_by_Account
- -> Forall_Journal_Balance_by_Account_Expanded
- expand = Format.journal_wrap
- rows_of_balance_by_account
- :: ( Format.Journal_Filter Context (Const bal_by_account) ()
- , Format.Journal_Wrap bal_by_account Forall_Journal_Balance_by_Unit
- , Format.Journal_Leijen_Table_Cells (Const bal_by_account) ()
- )
- => bal_by_account
- -> ( [[Leijen.Table.Cell]] -> [[Leijen.Table.Cell]]
- , [[Leijen.Table.Cell]] -> [[Leijen.Table.Cell]] )
- rows_of_balance_by_account =
- (***) Format.journal_leijen_table_cells
- Format.journal_leijen_table_cells .
- (&&&) id sum_by_unit .
- Format.journal_filter ctx .
- Const
- where
- sum_by_unit
- :: Format.Journal_Wrap bal_by_account Forall_Journal_Balance_by_Unit
- => Const bal_by_account ()
- -> Const Forall_Journal_Balance_by_Unit ()
- sum_by_unit = Const . Format.journal_wrap . getConst
-
-
-
-
-
-
-
-
-
-
--- * 'H.Balance_by_Account'
-
--- ** Type 'Format_Balance_by_Account'
-
-type Format_Journal_Balance_by_Account
- = Format
- ( JCC.Journal Balance_by_Account_JCC)
- (Ledger.Journal Balance_by_Account_Ledger)
-
--- JCC
-type Balance_by_Account_JCC
- = H.Balance_by_Account JCC.Account_Section
- JCC.Unit
- (H.Polarized JCC.Quantity)
-instance Format.Journal (JCC.Journal Balance_by_Account_JCC) where
- type Journal_Format (JCC.Journal Balance_by_Account_JCC)
- = Format_Journal_Balance_by_Account
- journal_format = Format_JCC
-
--- Ledger
-type Balance_by_Account_Ledger
- = H.Balance_by_Account Ledger.Account_Section
- Ledger.Unit
- (H.Polarized Ledger.Quantity)
-instance Format.Journal (Ledger.Journal Balance_by_Account_Ledger) where
- type Journal_Format (Ledger.Journal Balance_by_Account_Ledger)
- = Format_Journal_Balance_by_Account
- journal_format = Format_Ledger
-
--- ** Class 'Journal_Balance_by_Account'
-
-class
- ( Format.Journal (j m)
- , Format.Journal_Format (j m) ~ Format_Journal_Balance_by_Account
- , Format.Journal_Read j
- , Format.Journal_Monoid (j m)
- , Format.Journal_Leijen_Table_Cells j m
- , Format.Journal_Wrap (j m) Forall_Journal_Balance_by_Account_Expanded
- , Format.Journal_Wrap (j m) Forall_Journal_Balance_by_Unit
- , Format.Journal_Filter Context j m
- , Journal_Equilibrium_Transaction j m
- ) => Journal_Balance_by_Account j m
-
-instance Journal_Balance_by_Account JCC.Journal Balance_by_Account_JCC
-instance Journal_Balance_by_Account Ledger.Journal Balance_by_Account_Ledger
-
--- ** Type 'Forall_Journal_Balance_by_Account'
-
-data Forall_Journal_Balance_by_Account
- = forall j m. Journal_Balance_by_Account j m
- => Forall_Journal_Balance_by_Account (j m)
-
-instance Format.Journal Forall_Journal_Balance_by_Account where
- type Journal_Format Forall_Journal_Balance_by_Account = Format_Journal_Balance_by_Account
- journal_format
- (Forall_Journal_Balance_by_Account j) =
- Format.journal_format j
-instance Format.Journal_Empty Forall_Journal_Balance_by_Account where
- journal_empty f =
- case f of
- Format_JCC () -> Forall_Journal_Balance_by_Account (mempty::JCC.Journal Balance_by_Account_JCC)
- Format_Ledger () -> Forall_Journal_Balance_by_Account (mempty::Ledger.Journal Balance_by_Account_Ledger)
-instance Format.Journal_Monoid Forall_Journal_Balance_by_Account where
- journal_flatten
- (Forall_Journal_Balance_by_Account j) =
- Forall_Journal_Balance_by_Account $
- Format.journal_flatten j
- journal_fold f (Forall_Journal_Balance_by_Account j) =
- Format.journal_fold (f . Forall_Journal_Balance_by_Account) j
-instance Monoid Forall_Journal_Balance_by_Account where
- mempty = Forall_Journal_Balance_by_Account (mempty::JCC.Journal Balance_by_Account_JCC)
- mappend x y =
- case (mappend `on` Format.journal_format) x y of
- Format_JCC j -> Forall_Journal_Balance_by_Account j
- Format_Ledger j -> Forall_Journal_Balance_by_Account j
- mconcat js =
- case js of
- [] -> mempty
- j:jn -> List.foldl' mappend j jn
-
--- ** 'journal_read'
-
-type Journal_Filter_Simplified transaction
- = Filter.Simplified
- (Filter.Filter_Bool
- (Filter.Filter_Transaction transaction))
-type Journal_Read_Cons txn
- = txn -> Filter.Filtered (Journal_Filter_Simplified txn) txn
-journal_read
- :: Context -> FilePath
- -> IO (Either (Format.Message W.Doc) Forall_Journal_Balance_by_Account)
-journal_read ctx =
- case ctx_input_format ctx of
- Format_JCC () ->
- let wrap (j::JCC.Journal Balance_by_Account_JCC)
- = Forall_Journal_Balance_by_Account j in
- let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
- = Filter.Filtered (ctx_filter_transaction ctx) in
- liftM ((+++) Format.Message wrap) .
- Format.journal_read cons
- Format_Ledger () ->
- let wrap (j::Ledger.Journal Balance_by_Account_Ledger)
- = Forall_Journal_Balance_by_Account j in
- let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
- = Filter.Filtered (ctx_filter_transaction ctx) in
- liftM ((+++) Format.Message wrap) .
- Format.journal_read cons
-
-{-
--- ** Type family 'Balance_by_Account'
-
-type family Balance_by_Account (j:: * -> *) m
-type instance Balance_by_Account
- j (Balance.Expanded as u (Polarized q))
- = j (Balance.Balance_by_Account as u (Polarized q))
-type instance Balance_by_Account
- (Const Forall_Journal_Balance_by_Account_Expanded) ()
- = (Const Forall_Journal_Balance_by_Account ) ()
--}
-
--- Instances 'Format.Journal_Filter'
-
-instance
- ( Functor j
- , Format.Journal_Chart j
-
- , as ~ Format.Journal_Account_Section j
- , Data as
- {-, Filter.Account (Account_Tags, TreeMap.Path as)-}
- , NFData as
- , Ord as
- , Show as
-
- , q ~ Format.Journal_Quantity j
- , Format.Journal_Quantity j ~ Decimal
- , H.Addable q
- , H.Zero q
-
- , H.Unit u
- ) => Format.Journal_Filter Context j (H.Balance_by_Account as u (H.Polarized q)) where
- journal_filter ctx j =
- case Filter.simplified $ ctx_filter_balance ctx of
- Right True | ctx_redundant ctx -> j
- Right True ->
- TreeMap.filter_with_Path_and_Node
- (\n _p -> is_worth n) <$> j
- Right False -> const mempty <$> j
- Left flt ->
- (<$> j) $
- TreeMap.map_Maybe_with_Path_and_Node
- (\node account (H.Balance_by_Account_Sum bal) ->
- (if is_worth node bal then id else const Strict.Nothing) $
- case Map.mapMaybeWithKey
- (\unit qty ->
- if Filter.test flt
- ( (H.chart_account_tags account (Format.journal_chart j), account)
- , (unit, qty)
- )
- then Just qty
- else Nothing
- ) bal of
- m | Map.null m -> Strict.Nothing
- m -> Strict.Just $ H.Balance_by_Account_Sum m
- )
- where
- is_worth
- :: (Ord k0, Foldable t0, H.Addable a0, H.Zero a0)
- => TreeMap.Node k0 x0
- -> t0 (H.Polarized a0)
- -> Bool
- is_worth _node bal =
- ctx_redundant ctx
- -- NOTE: worth if no descendant
- -- but Account's exclusive
- -- has at least a non-zero Amount
- || Foldable.any
- (not . H.quantity_null . H.depolarize)
- bal
-instance Format.Journal_Filter Context (Const Forall_Journal_Balance_by_Account) () where
- journal_filter ctx
- (Const (Forall_Journal_Balance_by_Account j)) =
- Const $ Forall_Journal_Balance_by_Account $
- Format.journal_filter ctx j
-
--- Instances 'Format.Journal_Leijen_Table_Cells'
-
-instance
- ( Format.Journal_Content j
- , Journal j
-
- , as ~ Format.Journal_Account_Section j
- , Ord as
- , H.Addable (Format.Journal_Quantity j)
-
- , Leijen.Table.Cell_of_forall_param j (TreeMap.Path as)
-
- , Balance_by_Account_Sum amt
- , Balance_by_Account_Sum_Unit amt ~ Format.Journal_Unit j
- , Balance_by_Account_Sum_Quantity amt ~ H.Polarized (Format.Journal_Quantity j)
- ) => Format.Journal_Leijen_Table_Cells j (TreeMap as amt) where
- journal_leijen_table_cells jnl =
- flip (TreeMap.foldr_with_Path
- (\account balance rows ->
- let H.Balance_by_Account_Sum bal = balance_by_account_sum balance in
- Map.foldrWithKey
- (\unit qty ->
- zipWith (:)
- [ cell_of $ (unit,) <$> H.polarized_positive qty
- , cell_of $ (unit,) <$> H.polarized_negative qty
- , cell_of (unit, H.depolarize qty)
- , cell_of account
- ]
- )
- rows bal
- ))
- (Format.journal_content jnl)
- where
- cell_of :: Leijen.Table.Cell_of_forall_param j x => x -> Leijen.Table.Cell
- cell_of = Leijen.Table.cell_of_forall_param jnl
-instance Format.Journal_Leijen_Table_Cells (Const Forall_Journal_Balance_by_Account) () where
- journal_leijen_table_cells
- (Const (Forall_Journal_Balance_by_Account j)) =
- Format.journal_leijen_table_cells j
-
--- ** Class 'Balance_by_Account_Sum'
-
--- | A class to get a 'H.Balance_Account_Sum'
--- when operating on 'H.Balance_by_Account'
--- or 'H.Balance_Expanded' 'Strict.inclusive' field.
-class Balance_by_Account_Sum amt where
- type Balance_by_Account_Sum_Unit amt
- type Balance_by_Account_Sum_Quantity amt
- balance_by_account_sum
- :: amt -> H.Balance_by_Account_Sum (Balance_by_Account_Sum_Unit amt)
- (Balance_by_Account_Sum_Quantity amt)
-instance Balance_by_Account_Sum (H.Balance_by_Account_Sum u q) where
- type Balance_by_Account_Sum_Unit (H.Balance_by_Account_Sum u q) = u
- type Balance_by_Account_Sum_Quantity (H.Balance_by_Account_Sum u q) = q
- balance_by_account_sum = id
-instance Balance_by_Account_Sum (H.Balance_by_Account_Sum_Expanded u q) where
- type Balance_by_Account_Sum_Unit (H.Balance_by_Account_Sum_Expanded u q) = u
- type Balance_by_Account_Sum_Quantity (H.Balance_by_Account_Sum_Expanded u q) = q
- balance_by_account_sum = Strict.inclusive
-
--- * 'H.Balance_Expanded'
-
--- ** Type 'Format_Journal_Balance_by_Account_Expanded'
-
-type Format_Journal_Balance_by_Account_Expanded
- = Format
- ( JCC.Journal Balance_by_Account_Expanded_JCC)
- (Ledger.Journal Balance_by_Account_Expanded_Ledger)
-
--- JCC
-type Balance_by_Account_Expanded_JCC
- = H.Balance_Expanded JCC.Account_Section
- JCC.Unit
- (H.Polarized JCC.Quantity)
-instance Format.Journal (JCC.Journal Balance_by_Account_Expanded_JCC) where
- type Journal_Format (JCC.Journal Balance_by_Account_Expanded_JCC)
- = Format_Journal_Balance_by_Account_Expanded
- journal_format = Format_JCC
-
--- Ledger
-type Balance_by_Account_Expanded_Ledger
- = H.Balance_Expanded Ledger.Account_Section
- Ledger.Unit
- (H.Polarized Ledger.Quantity)
-instance Format.Journal (Ledger.Journal Balance_by_Account_Expanded_Ledger) where
- type Journal_Format (Ledger.Journal Balance_by_Account_Expanded_Ledger)
- = Format_Journal_Balance_by_Account_Expanded
- journal_format = Format_Ledger
-
--- ** Class 'Journal_Balance_by_Account_Expanded'
-
-class
- ( Format.Journal (j m)
- , Format.Journal_Format (j m) ~ Format_Journal_Balance_by_Account_Expanded
- , Format.Journal_Leijen_Table_Cells j m
- , Format.Journal_Wrap (j m) Forall_Journal_Balance_by_Unit
- , Format.Journal_Filter Context j m
- ) => Journal_Balance_by_Account_Expanded j m
-
-instance Journal_Balance_by_Account_Expanded JCC.Journal Balance_by_Account_Expanded_JCC
-instance Journal_Balance_by_Account_Expanded Ledger.Journal Balance_by_Account_Expanded_Ledger
-
--- ** Type 'Forall_Journal_Balance_by_Account_Expanded'
-
-data Forall_Journal_Balance_by_Account_Expanded
- = forall j m. Journal_Balance_by_Account_Expanded j m
- => Forall_Journal_Balance_by_Account_Expanded (j m)
-
-instance Format.Journal Forall_Journal_Balance_by_Account_Expanded where
- type Journal_Format Forall_Journal_Balance_by_Account_Expanded = Format_Journal_Balance_by_Account_Expanded
- journal_format
- (Forall_Journal_Balance_by_Account_Expanded j) =
- Format.journal_format j
-
--- Instances 'Format.Journal_Filter'
-
-instance
- ( Functor j
- , Format.Journal_Chart j
- , as ~ Format.Journal_Account_Section j
- , Data as
- {-, Filter.Account (Account_Tags, TreeMap.Path as)-}
- , NFData as
- , Ord as
- , Show as
- , q ~ Format.Journal_Quantity j
- , Format.Journal_Quantity j ~ Decimal
- , H.Addable q
- , H.Zero q
- , H.Unit u
- ) => Format.Journal_Filter Context j (H.Balance_Expanded as u (H.Polarized q)) where
- journal_filter ctx j =
- case Filter.simplified $ ctx_filter_balance ctx of
- Right True | ctx_redundant ctx -> j
- Right True ->
- TreeMap.filter_with_Path_and_Node
- (const . is_worth) <$> j
- Right False -> const mempty <$> j
- Left flt ->
- (<$> j) $
- TreeMap.map_Maybe_with_Path_and_Node
- (\node account bal ->
- (if is_worth node bal then id else const Strict.Nothing) $
- case Map.mapMaybeWithKey
- (\unit qty ->
- if Filter.test flt
- ( (H.chart_account_tags account (Format.journal_chart j), account)
- , (unit, qty)
- )
- then Just qty
- else Nothing
- ) (H.unBalance_by_Account_Sum $ Strict.inclusive bal) of
- m | Map.null m -> Strict.Nothing
- m -> Strict.Just $ bal{Strict.inclusive=H.Balance_by_Account_Sum m}
- )
- where
- is_worth node bal =
- let descendants = TreeMap.nodes
- (TreeMap.node_descendants node) in
- ctx_redundant ctx
- -- NOTE: worth if no descendant
- -- but Account's inclusive
- -- has at least a non-zero Amount
- || (Map.null descendants &&
- Foldable.any
- (not . H.quantity_null . H.depolarize)
- (H.unBalance_by_Account_Sum $ Strict.inclusive bal))
- -- NOTE: worth if Account's exclusive
- -- has at least a non-zero Amount
- || (Foldable.any
- (not . H.quantity_null . H.depolarize)
- (H.unBalance_by_Account_Sum $ Strict.exclusive bal))
- -- NOTE: worth if Account has at least more than
- -- one descendant Account whose inclusive
- -- has at least a non-zero Amount
- || Map.size
- ( Map.filter
- ( Strict.maybe False
- ( Foldable.any
- (not . H.quantity_null . H.depolarize)
- . H.unBalance_by_Account_Sum
- . Strict.inclusive )
- . TreeMap.node_value )
- descendants
- ) > 1
-instance Format.Journal_Filter Context (Const Forall_Journal_Balance_by_Account_Expanded) () where
- journal_filter ctx
- (Const (Forall_Journal_Balance_by_Account_Expanded j)) =
- Const $ Forall_Journal_Balance_by_Account_Expanded $
- Format.journal_filter ctx j
-
--- Instances 'Format.Journal_Leijen_Table_Cells'
-
-instance Format.Journal_Leijen_Table_Cells (Const Forall_Journal_Balance_by_Account_Expanded) x where
- journal_leijen_table_cells
- (Const (Forall_Journal_Balance_by_Account_Expanded j)) =
- Format.journal_leijen_table_cells j
-
--- Instances H.Balance_by_Account -> H.Balance_Expanded
-
-instance
- ( Functor j
- , Journal_Balance_by_Account_Expanded j (H.Balance_Expanded as u q)
-
- -- NOTE: constraints from H.balance_expanded
- , Ord as
- , Ord u
- , H.Addable q
- ) => Format.Journal_Wrap (j (H.Balance_by_Account as u q))
- Forall_Journal_Balance_by_Account_Expanded where
- journal_wrap =
- Forall_Journal_Balance_by_Account_Expanded .
- fmap H.balance_expanded
-
-instance Format.Journal_Wrap Forall_Journal_Balance_by_Account
- Forall_Journal_Balance_by_Account_Expanded where
- journal_wrap (Forall_Journal_Balance_by_Account j) = Format.journal_wrap j
-
-
-
-
-
-
-
-
-
-
-
--- * 'H.Balance_by_Unit'
-
-type Format_Journal_Balance_by_Unit
- = Format
- ( JCC.Journal Balance_by_Unit_JCC)
- (Ledger.Journal Balance_by_Unit_Ledger)
-
--- JCC
-type Balance_by_Unit_JCC
- = H.Balance_by_Unit JCC.Account
- JCC.Unit
- (H.Polarized JCC.Quantity)
-instance Format.Journal (JCC.Journal Balance_by_Unit_JCC) where
- type Journal_Format (JCC.Journal Balance_by_Unit_JCC)
- = Format_Journal_Balance_by_Unit
- journal_format = Format_JCC
-
--- Ledger
-type Balance_by_Unit_Ledger
- = H.Balance_by_Unit Ledger.Account
- Ledger.Unit
- (H.Polarized Ledger.Quantity)
-instance Format.Journal (Ledger.Journal Balance_by_Unit_Ledger) where
- type Journal_Format (Ledger.Journal Balance_by_Unit_Ledger)
- = Format_Journal_Balance_by_Unit
- journal_format = Format_Ledger
-
--- ** Class 'Journal_Balance_by_Unit'
-
-class
- ( Format.Journal (j m)
- , Format.Journal_Format (j m) ~ Format_Journal_Balance_by_Unit
- , Format.Journal_Leijen_Table_Cells j m
- -- , Journal_Equilibrium_Postings j m
- )
- => Journal_Balance_by_Unit j m
-
-instance Journal_Balance_by_Unit JCC.Journal Balance_by_Unit_JCC
-instance Journal_Balance_by_Unit Ledger.Journal Balance_by_Unit_Ledger
-
--- ** Type 'Forall_Journal_Balance_by_Unit'
-
-data Forall_Journal_Balance_by_Unit
- = forall j m. Journal_Balance_by_Unit j m
- => Forall_Journal_Balance_by_Unit (j m)
-
-instance Format.Journal Forall_Journal_Balance_by_Unit where
- type Journal_Format Forall_Journal_Balance_by_Unit = Format_Journal_Balance_by_Unit
- journal_format (Forall_Journal_Balance_by_Unit j) = Format.journal_format j
-
--- Instances H.Balance_by_Account -> H.Balance_by_Unit
-
-instance
- ( Functor j
- , Journal_Balance_by_Unit j (H.Balance_by_Unit (H.Account_Path as) u q)
-
- -- NOTE: constraints from H.balance_by_unit_of_by_account
- , H.Account (H.Account_Path as)
- , Ord as
- , Ord u
- , H.Addable q
- ) => Format.Journal_Wrap (j (H.Balance_by_Account as u q))
- Forall_Journal_Balance_by_Unit where
- journal_wrap =
- Forall_Journal_Balance_by_Unit .
- fmap (flip H.balance_by_unit_of_by_account mempty)
-
-instance Format.Journal_Wrap Forall_Journal_Balance_by_Account
- Forall_Journal_Balance_by_Unit where
- journal_wrap
- (Forall_Journal_Balance_by_Account j) =
- Format.journal_wrap j
-
--- Instances H.Balance_Expanded -> H.Balance_by_Unit
-
-instance
- ( Functor j
- , Journal_Balance_by_Unit j (H.Balance_by_Unit (H.Account_Path as) u q)
-
- -- NOTE: constraints from H.balance_by_unit_of_expanded
- , H.Account (H.Account_Path as)
- , Ord as
- , Ord u
- , H.Addable q
- ) => Format.Journal_Wrap (j (H.Balance_Expanded as u q))
- Forall_Journal_Balance_by_Unit where
- journal_wrap =
- Forall_Journal_Balance_by_Unit .
- fmap (flip H.balance_by_unit_of_expanded mempty)
-
-instance Format.Journal_Wrap Forall_Journal_Balance_by_Account_Expanded
- Forall_Journal_Balance_by_Unit where
- journal_wrap
- (Forall_Journal_Balance_by_Account_Expanded j) =
- Format.journal_wrap j
-
--- Instances 'Format.Journal_Leijen_Table_Cells'
-
-instance
- ( Format.Journal_Content j
- , Journal j
-
- , a ~ Format.Journal_Account j
- , H.Account a
- , u ~ Format.Journal_Unit j
- , Ord u
- , q ~ Format.Journal_Quantity j
- , H.Addable (Format.Journal_Quantity j)
- ) => Format.Journal_Leijen_Table_Cells j (H.Balance_by_Unit a u (H.Polarized q)) where
- journal_leijen_table_cells jnl acc =
- let H.Balance_by_Unit bal = Format.journal_content jnl in
- Map.foldrWithKey
- (\unit amt ->
- let qty = H.balance_by_unit_sum_quantity amt in
- zipWith (:)
- [ Leijen.Table.cell_of_forall_param jnl $ (unit,) <$> H.polarized_positive qty
- , Leijen.Table.cell_of_forall_param jnl $ (unit,) <$> H.polarized_negative qty
- , Leijen.Table.cell_of_forall_param jnl (unit, H.depolarize qty)
- , Leijen.Table.cell
- ]
- ) acc bal
-instance Format.Journal_Leijen_Table_Cells (Const Forall_Journal_Balance_by_Unit) () where
- journal_leijen_table_cells
- (Const (Forall_Journal_Balance_by_Unit j)) =
- Format.journal_leijen_table_cells j
-
-
-
-
-
-
-
-
-
--- * Class 'Journal'
-
-class
- ( Leijen.Table.Cell_of_forall_param j (Format.Journal_Unit j, Format.Journal_Quantity j)
- , W.ToDoc1 j [Format.Journal_Transaction j]
- ) => Journal (j:: * -> *) where
- journal_posting
- :: forall m. j m
- -> H.Account_Path (Format.Journal_Account_Section j)
- -> Map (Format.Journal_Unit j)
- (Format.Journal_Quantity j)
- -> [Text] -- ^ Comments
- -> Format.Journal_Posting j
- journal_transaction
- :: forall m. j m
- -> Text -- ^ Wording
- -> (H.Date, [H.Date])
- -> Map (H.Account_Path (Format.Journal_Account_Section j))
- [Format.Journal_Posting j]
- -> Format.Journal_Transaction j
-
-instance Journal JCC.Journal where
- journal_posting _j acct
- posting_amounts
- posting_comments =
- (JCC.posting acct)
- { JCC.posting_amounts
- , JCC.posting_comments
- }
- journal_transaction _j
- transaction_wording
- transaction_dates
- transaction_postings =
- JCC.transaction
- { JCC.transaction_wording
- , JCC.transaction_dates
- , JCC.transaction_postings
- }
-instance Journal Ledger.Journal where
- journal_posting _j acct
- posting_amounts
- posting_comments =
- (Ledger.posting acct)
- { Ledger.posting_amounts
- , Ledger.posting_comments
- }
- journal_transaction _j
- transaction_wording
- transaction_dates
- transaction_postings =
- Ledger.transaction
- { Ledger.transaction_wording
- , Ledger.transaction_dates
- , Ledger.transaction_postings
- }
-
-
-
-
-
-
-
-
-
-
-
-
-
--- * Class 'Journal_Equilibrium_Transaction'
-
-class Journal_Equilibrium_Transaction j m where
- journal_equilibrium_transaction
- :: j m
- -> C.Context
- -> Context
- -> Lang.Exercise_OC
- -> H.Date
- -> W.Doc
-
-instance
- ( Format.Journal_Content j
- , Journal j
-
- , as ~ Format.Journal_Account_Section j
- , Format.Journal_Account_Section j ~ Text
- , Format.Journal_Account j ~ TreeMap.Path Text
- , Num quantity
- , quantity ~ Format.Journal_Quantity j
- , Ord unit
- , Ord quantity
- , H.Zero (Format.Journal_Quantity j)
- , H.Addable (Format.Journal_Quantity j)
- , unit ~ Format.Journal_Unit j
- ) => Journal_Equilibrium_Transaction
- j (H.Balance_by_Account as unit (H.Polarized quantity)) where
- journal_equilibrium_transaction
- j c ctx oc now =
- let bal_by_account = Format.journal_content j in
- let H.Balance_by_Unit bal_by_unit =
- H.balance_by_unit_of_by_account bal_by_account mempty in
- let postings =
- Map.foldlWithKey
- (\acc unit H.Balance_by_Unit_Sum{..} ->
- let qty =
- (case oc of
- Lang.Exercise_Closing -> id
- Lang.Exercise_Opening -> negate) $
- H.depolarize balance_by_unit_sum_quantity in
- case H.quantity_sign qty of
- LT ->
- let account = snd $ ctx_account_equilibrium ctx in
- Map.insertWith mappend account
- [journal_posting j account
- (Map.singleton unit qty)
- [ Lang.translate (C.lang c) Lang.Comment_Equilibrium ]]
- acc
- EQ -> acc
- GT ->
- let account = fst $ ctx_account_equilibrium ctx in
- Map.insertWith mappend account
- [journal_posting j account
- (Map.singleton unit qty)
- [ Lang.translate (C.lang c) Lang.Comment_Equilibrium ]]
- acc
- )
- Map.empty
- bal_by_unit
- in
- W.toDoc1 j [
- journal_transaction j
- (Lang.translate (C.lang c) (Lang.Description_Exercise oc))
- (now{Time.utctDayTime=0}, []) $
- Map.unionWith mappend postings $
- TreeMap.flatten_with_Path
- (\posting_account (H.Balance_by_Account_Sum amount_by_unit) ->
- [ journal_posting j posting_account
- (flip fmap amount_by_unit $
- (case oc of
- Lang.Exercise_Closing -> negate
- Lang.Exercise_Opening -> id)
- . H.depolarize)
- []
- ]
- )
- bal_by_account
- ]
-
-instance Journal_Equilibrium_Transaction (Const Forall_Journal_Balance_by_Account) () where
- journal_equilibrium_transaction
- (Const (Forall_Journal_Balance_by_Account j)) =
- journal_equilibrium_transaction j
-
-{-
-instance
- ToDoc (C.Context, Context, Date, Lang.Exercise_OC)
- ( Forall_Journal_Balance_by_Account
- , Forall_Journal_Balance_by_Unit ) where
- toDoc c
- ( Forall_Journal_Balance_by_Account bal_by_account
- , Forall_Journal_Balance_by_Unit bal_by_unit
- ) =
- toDoc c (bal_by_account, bal_by_unit)
--}
+++ /dev/null
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.CLI.Command.GL where
-
-import Control.Applicative (Const(..), (<$>))
-import Control.Arrow (first, (+++))
-import Control.Monad (Monad(..), liftM, mapM)
-import Control.Monad.IO.Class (liftIO)
-import Data.Bool
-import Data.Decimal (Decimal)
-import Data.Either (Either(..), partitionEithers)
-import Data.Foldable (Foldable(..))
-import Data.Function (($), (.), on, id, flip)
-import Data.Functor (Functor(..))
-import Data.List ((++), repeat)
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Map
-import Data.Maybe (Maybe(..))
-import Data.Monoid (Monoid(..))
-import Data.Ord (Ord)
-import qualified Data.Sequence as Seq
-import qualified Data.Strict.Maybe as Strict
-import Data.String (String)
-import Data.Text (Text)
-import Prelude (Bounded(..), unlines, zipWith)
-import System.Console.GetOpt
- ( ArgDescr(..)
- , OptDescr(..)
- , usageInfo
- )
-import System.Environment as Env (getProgName)
-import System.Exit (exitSuccess)
-import qualified System.IO as IO
-import System.IO (FilePath, IO)
-
-import qualified Hcompta.Account as Account
-import qualified Hcompta.CLI.Args as Args
-import qualified Hcompta.CLI.Context as C
-import qualified Hcompta.CLI.Env as CLI.Env
-import Hcompta.CLI.Format.Ledger ()
-import Hcompta.CLI.Format.JCC ()
-import qualified Hcompta.CLI.Lang as Lang
-import qualified Hcompta.CLI.Lib.Leijen.Table as Leijen.Table
-import qualified Hcompta.CLI.Write as Write
-import qualified Hcompta.Chart as Chart
-import Hcompta.Date (Date)
-import qualified Hcompta.Filter as Filter
-import qualified Hcompta.Filter.Read as Filter.Read
-import qualified Hcompta.Format.JCC as JCC
-import qualified Hcompta.Format.Ledger as Ledger
-import qualified Hcompta.GL as GL
-import Hcompta.Lib.Leijen (toDoc, ToDoc(..))
-import qualified Hcompta.Lib.TreeMap as TreeMap
-import Hcompta.Polarize (Polarized)
-import qualified Hcompta.Polarize as Polarize
-import qualified Hcompta.Posting as Posting
-import qualified Hcompta.Filter.Amount as Filter.Amount
-import Hcompta.CLI.Format (Format(..), Formats)
-import qualified Hcompta.CLI.Format as Format
-import qualified Hcompta.Lib.Leijen as W
-import qualified Hcompta.Lib.Parsec as R
-import qualified Hcompta.Unit as Unit
-import qualified Hcompta.Quantity as Quantity
-
-data Context
- = Context
- { ctx_filter_transaction :: forall t.
- ( Filter.Transaction t
- , Filter.Amount_Quantity
- (Posting.Posting_Amount
- (Filter.Transaction_Posting t))
- ~ Filter.Amount.Quantity
- ) => Filter.Simplified
- (Filter.Filter_Bool
- (Filter.Filter_Transaction t))
- , ctx_filter_gl :: forall b.
- ( Filter.GL b
- , Filter.Amount_Quantity
- (Filter.GL_Amount b)
- ~ Filter.Amount.Quantity
- ) => Filter.Simplified
- (Filter.Filter_Bool
- (Filter.Filter_GL b))
- , ctx_input :: [FilePath]
- , ctx_input_format :: Formats
- , ctx_output :: [(Write.Mode, FilePath)]
- , ctx_output_format :: Maybe Formats
-
- -- , ctx_filter_gl :: Filter.Simplified
- -- (Filter.Filter_Bool
- -- (Filter.Filter_GL
- -- ( (Account_Tags, Ledger.Account)
- -- , Date
- -- , (Ledger.Unit, Polarize.Polarized Ledger.Quantity)
- -- , (Ledger.Unit, Polarize.Polarized Ledger.Quantity) )))
- -- , ctx_filter_posting :: Filter.Simplified
- -- (Filter.Filter_Bool
- -- (Filter.Filter_Posting
- -- (Ledger.Charted Ledger.Posting)))
- , ctx_reduce_date :: Bool
- } -- deriving (Show)
-
-context :: Context
-context =
- Context
- { ctx_filter_gl = Filter.Simplified $ Right True
- -- , ctx_filter_posting = Filter.Simplified $ Right True
- , ctx_filter_transaction = Filter.Simplified $ Right True
- , ctx_input = []
- , ctx_input_format = mempty
- , ctx_output = []
- , ctx_output_format = mempty
- , ctx_reduce_date = True
- }
-
-usage :: C.Context -> IO String
-usage c = do
- bin <- Env.getProgName
- return $ unlines $
- [ C.translate c Lang.Section_Description
- , " "++C.translate c Lang.Help_Command_General_Ledger
- , ""
- , C.translate c Lang.Section_Syntax
- , " "++bin++" gl ["++C.translate c Lang.Type_Option++"] [...]"++
- " ["++C.translate c Lang.Type_File_Journal++"] [...]"
- , ""
- , usageInfo (C.translate c Lang.Section_Options) (options c)
- ]
-
-options :: C.Context -> Args.Options Context
-options c =
- [ Option "g" ["filter-gl"]
- (ReqArg (\s ctx -> do
- filter <-
- R.runParserT_with_Error
- Filter.Read.filter_gl
- Filter.Read.context "" s
- case filter of
- Left (ko::[R.Error Filter.Read.Error]) -> Write.fatal c ko
- Right flt ->
- return $
- ctx{ctx_filter_gl =
- Filter.and (ctx_filter_gl ctx) $
- (Filter.simplify $
- Filter.Read.get_Forall_Filter_GL_Decimal <$> flt)
- }) $
- C.translate c Lang.Type_Filter_General_Ledger) $
- C.translate c Lang.Help_Option_Filter_General_Ledger
- {-, Option "p" ["filter-posting"]
- (ReqArg (\s ctx -> do
- ctx_filter_posting <-
- liftM ((ctx_filter_posting ctx <>) . Filter.simplify) $
- liftIO $ Filter.Read.read Filter.Read.filter_posting s
- >>= \f -> case f of
- Left ko -> Write.fatal c $ ko
- Right ok -> return ok
- return $ ctx{ctx_filter_posting}) $
- C.translate c Lang.Type_Filter_Posting) $
- C.translate c Lang.Help_Option_Filter_Posting
- -}
- , Option "t" ["filter-transaction"]
- (ReqArg (\s ctx -> do
- filter <-
- R.runParserT_with_Error
- Filter.Read.filter_transaction
- Filter.Read.context "" s
- case filter of
- Left ko -> Write.fatal c ko
- Right flt ->
- return $
- ctx{ctx_filter_transaction =
- Filter.and (ctx_filter_transaction ctx) $
- (Filter.simplify $
- Filter.Read.get_Forall_Filter_Transaction_Decimal <$> flt)
- }) $
- C.translate c Lang.Type_Filter_Transaction) $
- C.translate c Lang.Help_Option_Filter_Transaction
- , Option "h" ["help"]
- (NoArg (\_ctx -> do
- usage c >>= IO.hPutStr IO.stderr
- exitSuccess)) $
- C.translate c Lang.Help_Option_Help
- , Option "i" ["input"]
- (ReqArg (\s ctx -> do
- return $ ctx{ctx_input=s:ctx_input ctx}) $
- C.translate c Lang.Type_File_Journal) $
- C.translate c Lang.Help_Option_Input
- , Option "f" ["input-format"]
- (OptArg (\arg ctx -> do
- ctx_input_format <- case arg of
- Nothing -> return $ Format_JCC ()
- Just "jcc" -> return $ Format_JCC ()
- Just "ledger" -> return $ Format_Ledger ()
- Just _ -> Write.fatal c $
- W.text "--input-format option expects \"jcc\", or \"ledger\" as value"
- return $ ctx{ctx_input_format})
- "[jcc|ledger]")
- "input format"
- , Option "o" ["output"]
- (ReqArg (\s ctx -> do
- return $ ctx{ctx_output=(Write.Mode_Append, s):ctx_output ctx}) $
- C.translate c Lang.Type_File) $
- C.translate c Lang.Help_Option_Output
- , Option "F" ["output-format"]
- (ReqArg (\arg ctx -> do
- ctx_output_format <- case arg of
- "jcc" -> return $ Just $ Format_JCC ()
- "ledger" -> return $ Just $ Format_Ledger ()
- _ -> Write.fatal c $
- W.text "--output-format option expects \"jcc\", or \"ledger\" as value"
- return $ ctx{ctx_output_format})
- "[jcc|ledger]") $
- "output format"
- , Option "O" ["overwrite"]
- (ReqArg (\s ctx -> do
- return $ ctx{ctx_output=(Write.Mode_Over, s):ctx_output ctx}) $
- C.translate c Lang.Type_File) $
- C.translate c Lang.Help_Option_Overwrite
- {- NOTE: not used so far.
- , Option "" ["reduce-date"]
- (OptArg (\arg c ctx -> do
- ctx_reduce_date <- case arg of
- Nothing -> return $ True
- Just "yes" -> return $ True
- Just "no" -> return $ False
- Just _ -> Write.fatal c $
- W.text "--reduce-date option expects \"yes\", or \"no\" as value"
- return $ ctx{ctx_reduce_date})
- "[yes|no]")
- "use advanced date reducer to speed up filtering"
- -}
- ]
-
-run :: C.Context -> [String] -> IO ()
-run c args = do
- (ctx, inputs) <-
- first (\x ->
- case ctx_output x of
- [] -> x{ctx_output=[(Write.Mode_Append, "-")]}
- _ -> x) <$>
- Args.parse c usage options (context, args)
- input_paths <- CLI.Env.paths c $ ctx_input ctx ++ inputs
- read_journals <- mapM (liftIO . journal_read ctx) input_paths
- case partitionEithers read_journals of
- (errs@(_:_), _journals) -> Write.fatals c errs
- ([], (journals::[Forall_Journal_GL])) -> do
- let gl =
- mconcat $
- fmap Format.journal_flatten $
- case ctx_output_format ctx of
- Just f -> Format.journal_empty f:journals
- Nothing -> journals
- with_color <- Write.with_color c IO.stdout
- W.displayIO IO.stdout $
- W.renderPretty with_color 1.0 maxBound $
- toDoc () $ Leijen.Table.table_of (c, ctx) gl
- {-
- Write.debug c $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
- Write.debug c $ "filter: posting: " ++ show (ctx_filter_posting ctx)
- Write.debug c $ "filter: balance: " ++ show (ctx_filter_balance ctx)
- -}
-
-instance Leijen.Table.Table_of (C.Context, Context) Forall_Journal_GL where
- table_of (c, ctx) gl =
- let lang = C.lang c in
- zipWith id
- [ Leijen.Table.column (Lang.translate lang Lang.Title_Account) Leijen.Table.Align_Left
- , Leijen.Table.column (Lang.translate lang Lang.Title_Date) Leijen.Table.Align_Left
- , Leijen.Table.column (Lang.translate lang Lang.Title_Debit) Leijen.Table.Align_Right
- , Leijen.Table.column (Lang.translate lang Lang.Title_Credit) Leijen.Table.Align_Right
- , Leijen.Table.column (Lang.translate lang Lang.Title_Running_debit) Leijen.Table.Align_Right
- , Leijen.Table.column (Lang.translate lang Lang.Title_Running_credit) Leijen.Table.Align_Right
- , Leijen.Table.column (Lang.translate lang Lang.Title_Running_balance) Leijen.Table.Align_Right
- , Leijen.Table.column (Lang.translate lang Lang.Title_Description) Leijen.Table.Align_Left
- ] $
- Format.journal_leijen_table_cells
- (Format.journal_filter ctx $
- (Const::x -> Const x ()) gl) $
- repeat []
-
-
--- * 'GL.GL'
-
--- ** Type 'Format_GL'
-
-type Format_Journal_GL
- = Format
- ( JCC.Journal GL_JCC)
- (Ledger.Journal GL_Ledger)
-
--- JCC
-type GL_JCC
- = GL.GL (JCC.Charted JCC.Transaction)
- -- = GL.GL JCC.Transaction
-instance Format.Journal (JCC.Journal GL_JCC) where
- type Journal_Format (JCC.Journal GL_JCC)
- = Format_Journal_GL
- journal_format = Format_JCC
-
--- Ledger
-type GL_Ledger
- -- = GL.GL Ledger.Transaction
- = GL.GL (Ledger.Charted Ledger.Transaction)
-instance Format.Journal (Ledger.Journal GL_Ledger) where
- type Journal_Format (Ledger.Journal GL_Ledger)
- = Format_Journal_GL
- journal_format = Format_Ledger
-
--- ** Class 'Journal'
-
-class
- ( Format.Journal_Read j
- , Ord (Account.Account_Section (Format.Journal_Account j))
- , Leijen.Table.Cell_of_forall_param j
- (TreeMap.Path (Account.Account_Section
- (GL.Posting_Account (Format.Journal_Posting j))))
- , Leijen.Table.Cell_of_forall_param j
- (Format.Journal_Unit j, Format.Journal_Quantity j)
- , Leijen.Table.Cell_of_forall_param j
- (TreeMap.Path (Account.Account_Section (GL.Posting_Account
- (Chart.Charted (Format.Journal_Account j)
- (Format.Journal_Posting j)))))
- , Polarize.Polarizable (Format.Journal_Quantity j)
- ) => Journal j
- where
- journal_transaction_wording
- :: forall m. j m
- -> Format.Journal_Transaction j
- -> Text
- journal_posting_amounts
- :: forall m. j m
- -> Format.Journal_Posting j
- -> Map (Format.Journal_Unit j)
- (Format.Journal_Quantity j)
- journal_posting_amounts_set
- :: forall m. j m
- -> Map (Format.Journal_Unit j)
- (Format.Journal_Quantity j)
- -> Format.Journal_Posting j
- -> Format.Journal_Posting j
-
-instance Journal JCC.Journal
- where
- journal_transaction_wording _j = JCC.transaction_wording
- journal_posting_amounts _j = JCC.posting_amounts
- journal_posting_amounts_set _j posting_amounts p =
- p { JCC.posting_amounts }
-instance Journal Ledger.Journal
- where
- journal_transaction_wording _j = Ledger.transaction_wording
- journal_posting_amounts _j = Ledger.posting_amounts
- journal_posting_amounts_set _j posting_amounts p =
- p { Ledger.posting_amounts }
-
--- ** Class 'Journal_GL'
-
-class
- ( Format.Journal (j m)
- , Format.Journal_Format (j m) ~ Format_Journal_GL
- , Format.Journal_Read j
- , Format.Journal_Monoid (j m)
- , Format.Journal_Leijen_Table_Cells j m
- , Format.Journal_Filter Context j m
- ) => Journal_GL j m
-
-instance Journal_GL JCC.Journal GL_JCC
-instance Journal_GL Ledger.Journal GL_Ledger
-
--- ** Type 'Forall_Journal_GL'
-
-data Forall_Journal_GL
- = forall j m. Journal_GL j m
- => Forall_Journal_GL (j m)
-
-instance Format.Journal Forall_Journal_GL where
- type Journal_Format Forall_Journal_GL = Format_Journal_GL
- journal_format
- (Forall_Journal_GL j) =
- Format.journal_format j
-instance Format.Journal_Empty Forall_Journal_GL where
- journal_empty f =
- case f of
- Format_JCC () -> Forall_Journal_GL (mempty::JCC.Journal GL_JCC)
- Format_Ledger () -> Forall_Journal_GL (mempty::Ledger.Journal GL_Ledger)
-instance Format.Journal_Monoid Forall_Journal_GL where
- journal_flatten
- (Forall_Journal_GL j) =
- Forall_Journal_GL $
- Format.journal_flatten j
- journal_fold f (Forall_Journal_GL j) =
- Format.journal_fold (f . Forall_Journal_GL) j
-instance Monoid Forall_Journal_GL where
- mempty = Forall_Journal_GL (mempty::JCC.Journal GL_JCC)
- mappend x y =
- case (mappend `on` Format.journal_format) x y of
- Format_JCC j -> Forall_Journal_GL j
- Format_Ledger j -> Forall_Journal_GL j
- mconcat js =
- case js of
- [] -> mempty
- j:jn -> foldl' mappend j jn
-
-
--- *** 'journal_read'
-
-type Journal_Filter_Simplified transaction
- = Filter.Simplified
- (Filter.Filter_Bool
- (Filter.Filter_Transaction transaction))
-type Journal_Read_Cons txn
- = txn -> Filter.Filtered (Journal_Filter_Simplified txn) txn
-journal_read
- :: Context -> FilePath
- -> IO (Either (Format.Message W.Doc) Forall_Journal_GL)
-journal_read ctx =
- case ctx_input_format ctx of
- Format_JCC () ->
- let wrap (j::JCC.Journal GL_JCC)
- = Forall_Journal_GL j in
- let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
- = Filter.Filtered (ctx_filter_transaction ctx) in
- liftM ((+++) Format.Message wrap) .
- Format.journal_read cons
- Format_Ledger () ->
- let wrap (j::Ledger.Journal GL_Ledger)
- = Forall_Journal_GL j in
- let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
- = Filter.Filtered (ctx_filter_transaction ctx) in
- liftM ((+++) Format.Message wrap) .
- Format.journal_read cons
-
-
--- Instances 'Format.Journal_Filter'
-
-instance
- ( Functor j
- , Format.Journal_Chart j
- , Journal j
- , Journal_GL j (GL.GL t)
- , GL.Transaction t
- , Format.Journal_Account_Section j ~ Text
- , GL.Transaction_Posting t
- ~ Chart.Charted (Format.Journal_Account j)
- (Format.Journal_Posting j)
- , GL.Posting_Quantity (GL.Transaction_Posting t)
- ~ Map (Format.Journal_Unit j)
- (Polarized (Format.Journal_Quantity j))
- , Format.Journal_Quantity j ~ Decimal
- , Format.Journal_Account_Section j
- ~ Account.Account_Section (GL.Posting_Account (GL.Transaction_Posting t))
- , Ord (Format.Journal_Unit j)
- , Unit.Unit (Format.Journal_Unit j)
- ) => Format.Journal_Filter Context j (GL.GL t) where
- journal_filter ctx j =
- GL.GL .
- TreeMap.map_Maybe_with_Path
- (\acct expanded_lines ->
- let chart = Format.journal_chart j in
- case Map.mapMaybeWithKey
- (\date seq_lines ->
- case foldMap
- (\line@GL.GL_Line
- { GL.gl_line_transaction = _t
- , GL.gl_line_posting = p
- , GL.gl_line_sum = s
- } ->
- Map.foldlWithKey
- (\acc unit qty ->
- let sqty = (Map.!) s unit in
- if Filter.test (ctx_filter_gl ctx)
- ( (Chart.account_tags acct chart, acct)
- , date
- , (unit, Polarize.polarize qty)
- , (unit, sqty)
- )
- then (Seq.|>) acc line
- { GL.gl_line_posting =
- journal_posting_amounts_set j
- (Map.singleton unit qty) <$> p
- , GL.gl_line_sum = Map.singleton unit sqty
- }
- else acc
- )
- Seq.empty
- (journal_posting_amounts j $ Chart.charted p)
- ) seq_lines
- of
- m | Seq.null m -> Nothing
- m -> Just m
- )
- (GL.inclusive expanded_lines)
- of
- m | Map.null m -> Strict.Nothing
- m -> Strict.Just m
- ) .
- (\(GL.Expanded gl) -> gl) .
- GL.expanded <$> j
-instance Format.Journal_Filter Context (Const Forall_Journal_GL) () where
- journal_filter ctx
- (Const (Forall_Journal_GL j)) =
- Const $ Forall_Journal_GL $
- Format.journal_filter ctx j
-
--- Instances 'Format.Journal_Leijen_Table_Cells'
-
-instance
- ( Format.Journal_Content j
- , Journal j
-
- , Quantity.Addable (Format.Journal_Quantity j)
- , GL.Transaction_Posting t
- ~ Chart.Charted (Format.Journal_Account j)
- (Format.Journal_Posting j)
- , Format.Journal_Transaction j ~ GL.Transaction_Line t
- , GL.Posting_Quantity (Chart.Charted (Format.Journal_Account j)
- (Format.Journal_Posting j))
- ~ Map (Format.Journal_Unit j)
- (Polarized (Format.Journal_Quantity j))
- , GL.Posting_Quantity (Format.Journal_Posting j)
- ~ Map (Format.Journal_Unit j)
- (Polarized (Format.Journal_Quantity j))
- -- , GL.Posting_Account t ~ Format.Journal_Account j
- -- , Leijen.Table.Cell_of_forall_param j (TreeMap.Path as)
- , Leijen.Table.Cell_of_forall_param j Date
- , Leijen.Table.Cell_of_forall_param j Text
- , Ord (Format.Journal_Unit j)
- , GL.Transaction t
- ) => Format.Journal_Leijen_Table_Cells j (GL.GL t) where
- journal_leijen_table_cells jnl =
- flip (TreeMap.foldr_with_Path
- (\account ->
- flip $ Map.foldrWithKey
- (\date ->
- flip $ foldr
- (\GL.GL_Line
- { GL.gl_line_transaction = t
- , GL.gl_line_posting = p
- , GL.gl_line_sum = s
- } ->
- flip (Map.foldrWithKey
- (\unit qty ->
- let ms = Map.lookup unit s in
- zipWith (:)
- [ cell_of account
- , cell_of date
- , cell_of $ (unit,) <$> Polarize.polarizable_positive qty
- , cell_of $ (unit,) <$> Polarize.polarizable_negative qty
- , cell_of $ (unit,) <$> (ms >>= Polarize.polarized_positive)
- , cell_of $ (unit,) <$> (ms >>= Polarize.polarized_negative)
- , cell_of $ (unit,) . Polarize.depolarize <$> ms
- , cell_of $ journal_transaction_wording jnl t
- ]
- ))
- (journal_posting_amounts jnl $ Chart.charted p)
- )
- )
- )) $
- (\(GL.GL x) -> x)
- (Format.journal_content jnl)
- where
- cell_of :: Leijen.Table.Cell_of_forall_param j x => x -> Leijen.Table.Cell
- cell_of = Leijen.Table.cell_of_forall_param jnl
-
-instance Format.Journal_Leijen_Table_Cells (Const Forall_Journal_GL) () where
- journal_leijen_table_cells
- (Const (Forall_Journal_GL j)) =
- Format.journal_leijen_table_cells j
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-{-
--- Instances GL.GL -> GL.Expanded
-
-instance
- ( Functor j
- , Journal_GL_Expanded j (GL.Expanded t)
-
- -- NOTE: constraint from GL.expanded
- , GL.Transaction t
- ) => Format.Journal_Wrap (j (GL.GL t))
- Forall_Journal_GL_Expanded where
- journal_wrap =
- Forall_Journal_GL_Expanded .
- fmap GL.expanded
-
-instance Format.Journal_Wrap Forall_Journal_GL
- Forall_Journal_GL_Expanded where
- journal_wrap (Forall_Journal_GL j) = Format.journal_wrap j
--}
-{-
--- * 'GL.GL_Expanded'
-
--- ** Type 'Format_GL_Expanded'
-
-type Format_Journal_GL_Expanded
- = Format
- ( JCC.Journal GL_Expanded_JCC)
- (Ledger.Journal GL_Expanded_Ledger)
-
--- JCC
-type GL_Expanded_JCC
- = GL.Expanded (JCC.Charted JCC.Transaction)
-instance Format.Journal (JCC.Journal GL_Expanded_JCC) where
- type Journal_Format (JCC.Journal GL_Expanded_JCC)
- = Format_Journal_GL_Expanded
- journal_format = Format_JCC
-
--- Ledger
-type GL_Expanded_Ledger
- = GL.Expanded (Ledger.Charted Ledger.Transaction)
-instance Format.Journal (Ledger.Journal GL_Expanded_Ledger) where
- type Journal_Format (Ledger.Journal GL_Expanded_Ledger)
- = Format_Journal_GL_Expanded
- journal_format = Format_Ledger
-
--- ** Class 'Journal_GL_Expanded'
-
-class
- ( Format.Journal (j m)
- , Format.Journal_Format (j m) ~ Format_Journal_GL_Expanded
- -- , Format.Journal_Leijen_Table_Cells j m
- , Format.Journal_Filter Context j m
- ) => Journal_GL_Expanded j m where
- journal_posting_amounts
- :: j m
- -> Format.Journal_Posting j
- -> Map (Format.Journal_Unit j)
- (Format.Journal_Quantity j)
- journal_posting_amounts_set
- :: j m
- -> Map (Format.Journal_Unit j)
- (Format.Journal_Quantity j)
- -> Format.Journal_Posting j
- -> Format.Journal_Posting j
-
-instance Journal_GL_Expanded JCC.Journal GL_Expanded_JCC
- where
- journal_posting_amounts _j = JCC.posting_amounts
- journal_posting_amounts_set _j posting_amounts p =
- p { JCC.posting_amounts }
-instance Journal_GL_Expanded Ledger.Journal GL_Expanded_Ledger
- where
- journal_posting_amounts _j = Ledger.posting_amounts
- journal_posting_amounts_set _j posting_amounts p =
- p { Ledger.posting_amounts }
-
--- ** Type 'Forall_Journal_GL_Expanded'
-
-data Forall_Journal_GL_Expanded
- = forall j m. Journal_GL_Expanded j m
- => Forall_Journal_GL_Expanded (j m)
-
-instance Format.Journal Forall_Journal_GL_Expanded where
- type Journal_Format Forall_Journal_GL_Expanded = Format_Journal_GL_Expanded
- journal_format
- (Forall_Journal_GL_Expanded j) =
- Format.journal_format j
-
--- Instances 'Format.Journal_Filter'
-
-instance
- ( Functor j
- , Format.Journal_Chart j
- , Journal_GL_Expanded j (GL.Expanded t)
- , GL.Transaction t
- , Format.Journal_Account_Section j ~ Text
- , GL.Transaction_Posting t ~ Chart.Charted (Format.Journal_Account j) (Format.Journal_Posting j)
- , GL.Posting_Quantity (GL.Transaction_Posting t)
- ~ Map (Format.Journal_Unit j) (Polarized (Format.Journal_Quantity j))
- , Format.Journal_Quantity j ~ Decimal
- , Format.Journal_Account_Section j
- ~ Account.Account_Section (GL.Posting_Account (GL.Transaction_Posting t))
- , Ord (Format.Journal_Unit j)
- , Unit.Unit (Format.Journal_Unit j)
- ) => Format.Journal_Filter Context j (GL.Expanded t) where
- journal_filter ctx j =
- GL.Expanded .
- TreeMap.map_Maybe_with_Path
- (\acct expanded_lines ->
- let chart = Format.journal_chart j in
- case Map.mapMaybeWithKey
- (\date seq_lines ->
- case foldMap
- (\line@GL.GL_Line
- { GL.gl_line_transaction = _t
- , GL.gl_line_posting = Chart.Charted ch p
- , GL.gl_line_sum = s
- } ->
- Map.foldlWithKey
- (\acc unit qty ->
- let sqty = (Map.!) s unit in
- if Filter.test (ctx_filter_gl ctx)
- ( (Chart.account_tags acct chart, acct)
- , date
- , (unit, Polarize.polarize qty)
- , (unit, sqty)
- )
- then (Seq.|>) acc line
- { GL.gl_line_posting =
- Chart.Charted ch $
- journal_posting_amounts_set j
- (Map.singleton unit qty) p
- , GL.gl_line_sum = Map.singleton unit sqty
- }
- else acc
- )
- Seq.empty
- (journal_posting_amounts j p)
- ) seq_lines
- of
- m | Seq.null m -> Nothing
- m -> Just m
- )
- (GL.inclusive expanded_lines)
- of
- m | Map.null m -> Strict.Nothing
- m -> Strict.Just $ expanded_lines { GL.inclusive=m }
- ) .
- (\(GL.Expanded gl) -> gl) <$> j
-
-instance Format.Journal_Filter Context (Const Forall_Journal_GL_Expanded) () where
- journal_filter ctx
- (Const (Forall_Journal_GL_Expanded j)) =
- Const $ Forall_Journal_GL_Expanded $
- Format.journal_filter ctx j
--}
-
-{-
-run :: C.Context -> [String] -> IO ()
-run c args = do
- (ctx, inputs) <-
- first (\x ->
- case ctx_output x of
- [] -> x{ctx_output=[(Write.Mode_Append, "-")]}
- _ -> x) <$>
- Args.parse c usage options (context, args)
- read_journals <-
- liftM partitionEithers $ do
- CLI.Env.paths c $ ctx_input ctx ++ inputs
- >>= do
- mapM $ \path -> do
- liftIO $ runExceptT $ Ledger.Read.file
- (Ledger.Read.context ( ctx_filter_transaction ctx
- , ctx_filter_posting ctx )
- Ledger.journal)
- path
- >>= \x -> case x of
- Left ko -> return $ Left (path, ko)
- Right ok -> return $ Right ok
- case read_journals of
- (errs@(_:_), _journals) ->
- forM_ errs $ \(_path, err) -> do
- Write.fatal c $ err
- ([], journals) -> do
- Write.debug c $ "filter: transaction: " ++ show (ctx_filter_transaction ctx)
- Write.debug c $ "filter: posting: " ++ show (ctx_filter_posting ctx)
- Write.debug c $ "filter: gl: " ++ show (ctx_filter_gl ctx)
- let (amount_styles, gl) = ledger_gl ctx journals
- let lang = C.lang c
- Write.write c Write.style (ctx_output ctx) $ do
- toDoc () $ do
- zipWith id
- [ Table.column (Lang.translate lang Lang.Title_Account) Table.Align_Left
- , Table.column (Lang.translate lang Lang.Title_Date) Table.Align_Left
- , Table.column (Lang.translate lang Lang.Title_Debit) Table.Align_Right
- , Table.column (Lang.translate lang Lang.Title_Credit) Table.Align_Right
- , Table.column (Lang.translate lang Lang.Title_Running_debit) Table.Align_Right
- , Table.column (Lang.translate lang Lang.Title_Running_credit) Table.Align_Right
- , Table.column (Lang.translate lang Lang.Title_Running_balance) Table.Align_Right
- , Table.column (Lang.translate lang Lang.Title_Description) Table.Align_Left
- ] $ do
- write_gl amount_styles gl (repeat [])
--}
-
-{-
-ledger_gl
- :: Context
- -> [ Ledger.Journal (GL.GL (Ledger.Charted Ledger.Transaction)) ]
- -> ( Ledger.Amount.Styles
- , GL (Ledger.Charted Ledger.Transaction)
- )
-ledger_gl ctx journals =
- let (_chart, amount_styles, gl) =
- foldl'
- (flip (\j ->
- flip mappend $
- ( Ledger.journal_chart j
- , Ledger.journal_amount_styles j
- , ) $
- Ledger.Journal.fold
- (\Ledger.Journal
- { Ledger.journal_sections=g
- } -> mappend g
- ) j mempty
- ))
- mempty journals in
- (amount_styles,) $
- GL.GL $
- TreeMap.map_Maybe_with_Path
- (\acct expanded_lines ->
- case Map.mapMaybeWithKey
- (\date seq_lines ->
- case foldMap
- (\line@GL.GL_Line
- { GL.gl_line_transaction = _t
- , GL.gl_line_posting = Ledger.Charted c p
- , GL.gl_line_sum = s
- } ->
- Map.foldlWithKey
- (\acc unit qty ->
- let sqty = (Map.!) s unit in
- if Filter.test (ctx_filter_gl ctx)
- ( (Chart.account_tags acct c, acct)
- , date
- , (unit, Polarize.polarize qty)
- , (unit, sqty)
- )
- then (Seq.|>) acc line
- { GL.gl_line_posting = Ledger.Charted c p
- { Ledger.posting_amounts = Map.singleton unit qty }
- , GL.gl_line_sum = Map.singleton unit sqty
- }
- else acc
- )
- Seq.empty
- (Ledger.posting_amounts p)
- ) seq_lines of
- m | Seq.null m -> Nothing
- m -> Just m
- )
- (GL.inclusive expanded_lines) of
- m | Map.null m -> Strict.Nothing
- m -> Strict.Just m
- ) $
- GL.expanded gl
-
-write_gl
- :: Ledger.Amount.Styles
- -> GL (Ledger.Charted Ledger.Transaction)
- -> [[Table.Cell]]
- -> [[Table.Cell]]
-write_gl amount_styles (GL gl) =
- flip (TreeMap.foldr_with_Path
- (\acct ->
- flip $ Map.foldrWithKey
- (\date ->
- flip (foldr
- (\GL.GL_Line
- { GL.gl_line_transaction = Ledger.Charted _ t
- , GL.gl_line_posting = Ledger.Charted _ p
- , GL.gl_line_sum = s
- } ->
- flip (Map.foldrWithKey
- (\unit qty ->
- let ms = Map.lookup unit s in
- zipWith (:)
- [ let ptype = Ledger.Posting_Type_Regular in
- Table.cell
- { Table.cell_content = Ledger.Write.account ptype acct
- , Table.cell_width = Ledger.Write.account_length ptype acct
- }
- , Table.cell
- { Table.cell_content = Date.Write.date date
- , Table.cell_width = Date.Write.date_length date
- }
- , cell_amount unit (Polarize.polarizable_positive qty)
- , cell_amount unit (Polarize.polarizable_negative qty)
- , cell_amount unit (ms >>= Polarize.polarized_positive)
- , cell_amount unit (ms >>= Polarize.polarized_negative)
- , cell_amount unit (liftM Polarize.depolarize ms)
- , let descr = Ledger.transaction_wording t in
- Table.cell
- { Table.cell_content = toDoc () descr
- , Table.cell_width = Text.length descr
- }
- ]
- ))
- (Ledger.posting_amounts p)
- ))
- )
- ))
- gl
- where
- cell_amount :: Ledger.Unit -> Maybe Ledger.Quantity -> Table.Cell
- cell_amount unit mq =
- case mq of
- Nothing -> Table.cell
- Just q ->
- let a = Ledger.Amount.Amount unit q in
- let sa = Ledger.Amount.style amount_styles a in
- Table.cell
- { Table.cell_content = Amount.Write.amount sa
- , Table.cell_width = Amount.Write.amount_length sa
- }
--}
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.CLI.Command.Journal where
-
-import Control.Arrow ((+++))
-import Control.Monad (Monad(..), liftM, mapM)
-import Control.Monad.IO.Class (liftIO)
-import Data.Bool
-import Data.Either (Either(..), partitionEithers)
-import Data.Foldable (Foldable(..))
-import Data.Function (($), (.), on)
-import Data.Functor (Functor(..), (<$>))
-import Data.List ((++))
-import Data.Maybe (Maybe(..))
-import Data.Monoid (Monoid(..))
-import Data.String (String)
-import Prelude (Bounded(..), unlines)
-import System.Console.GetOpt
- ( ArgDescr(..)
- , OptDescr(..)
- , usageInfo )
-import System.Environment as Env (getProgName)
-import System.Exit (exitSuccess)
-import qualified System.IO as IO
-import System.IO (FilePath, IO)
-
-import qualified Hcompta.CLI.Args as Args
-import qualified Hcompta.CLI.Context as C
-import qualified Hcompta.CLI.Env as CLI.Env
-import qualified Hcompta.CLI.Format as Format
-import Hcompta.CLI.Format.JCC ()
-import Hcompta.CLI.Format.Ledger ()
-import Hcompta.CLI.Format (Format(..), Formats)
-import qualified Hcompta.CLI.Lang as Lang
-import qualified Hcompta.CLI.Write as Write
-import qualified Hcompta.Chart as Chart
-import qualified Hcompta.Posting as Posting
-import qualified Hcompta.Filter as Filter
-import qualified Hcompta.Filter.Amount as Filter.Amount
-import qualified Hcompta.Filter.Read as Filter.Read
-import qualified Hcompta.Format.JCC as JCC
-import qualified Hcompta.Format.JCC.Write as JCC.Write
-import qualified Hcompta.Format.Ledger as Ledger
-import qualified Hcompta.Format.Ledger.Write as Ledger
-import qualified Hcompta.Journal as Journal
--- import Hcompta.Lib.Consable (Consable(..))
-import qualified Hcompta.Lib.Leijen as W
-import qualified Hcompta.Lib.Parsec as R
-
-data Context
- = Context
- { ctx_input :: [FilePath]
- , ctx_input_format :: Formats
- , ctx_output :: [(Write.Mode, FilePath)]
- , ctx_output_format :: Maybe Formats
- , ctx_align :: Bool
- , ctx_reduce_date :: Bool
- , ctx_filter_transaction :: forall t.
- ( Filter.Transaction t
- , Filter.Amount_Quantity
- (Posting.Posting_Amount
- (Filter.Transaction_Posting t))
- ~ Filter.Amount.Quantity
- ) => Journal_Filter t
- }
-
-context :: Context
-context =
- Context
- { ctx_input = []
- , ctx_input_format = mempty
- , ctx_output = []
- , ctx_output_format = Nothing
- , ctx_align = True
- , ctx_reduce_date = True
- , ctx_filter_transaction = Filter.Simplified $ Right True
- }
-
-usage :: C.Context -> IO String
-usage c = do
- bin <- Env.getProgName
- return $ unlines $
- [ C.translate c Lang.Section_Description
- , " "++C.translate c Lang.Help_Command_Journal
- , ""
- , C.translate c Lang.Section_Syntax
- , " "++bin++" journal ["++C.translate c Lang.Type_Option++"] [...]"++
- " ["++C.translate c Lang.Type_File_Journal++"] [...]"
- , ""
- , usageInfo (C.translate c Lang.Section_Options) (options c)
- ]
-
-options :: C.Context -> Args.Options Context
-options c =
- [ Option "h" ["help"]
- (NoArg (\_ctx -> do
- usage c >>= IO.hPutStr IO.stderr
- exitSuccess)) $
- C.translate c Lang.Help_Option_Help
- , Option "i" ["input"]
- (ReqArg (\s ctx -> do
- return $ ctx{ctx_input=s:ctx_input ctx}) $
- C.translate c Lang.Type_File_Journal) $
- C.translate c Lang.Help_Option_Input
- , Option "if" ["input-format"]
- (OptArg (\arg ctx -> do
- ctx_input_format <- case arg of
- Nothing -> return $ Format_JCC ()
- Just "jcc" -> return $ Format_JCC ()
- Just "ledger" -> return $ Format_Ledger ()
- Just _ -> Write.fatal c $
- W.text "--input-format option expects \"jcc\", or \"ledger\" as value"
- return $ ctx{ctx_input_format})
- "[jcc|ledger]")
- "input format"
- , Option "o" ["output"]
- (ReqArg (\s ctx -> do
- return $ ctx{ctx_output=(Write.Mode_Append, s):ctx_output ctx}) $
- C.translate c Lang.Type_File) $
- C.translate c Lang.Help_Option_Output
- , Option "of" ["output-format"]
- (OptArg (\arg ctx -> do
- ctx_output_format <- case arg of
- Nothing -> return $ Just $ Format_JCC ()
- Just "jcc" -> return $ Just $ Format_JCC ()
- Just "ledger" -> return $ Just $ Format_Ledger ()
- Just _ -> Write.fatal c $
- W.text "--output-format option expects \"jcc\", or \"ledger\" as value"
- return $ ctx{ctx_output_format})
- "[jcc|ledger]")
- "input format"
- , Option "O" ["overwrite"]
- (ReqArg (\s ctx -> do
- return $ ctx{ctx_output=(Write.Mode_Over, s):ctx_output ctx}) $
- C.translate c Lang.Type_File) $
- C.translate c Lang.Help_Option_Overwrite
- , Option "" ["align"]
- (OptArg (\arg ctx -> do
- ctx_align <- case arg of
- Nothing -> return $ True
- Just "yes" -> return $ True
- Just "no" -> return $ False
- Just _ -> Write.fatal c $
- W.text "--align option expects \"yes\", or \"no\" as value"
- return $ ctx{ctx_align})
- "[yes|no]")
- "align output"
- {- NOTE: not used so far.
- , Option "" ["reduce-date"]
- (OptArg (\arg ctx -> do
- ctx_reduce_date <- case arg of
- Nothing -> return $ True
- Just "yes" -> return $ True
- Just "no" -> return $ False
- Just _ -> Write.fatal c $
- W.text "--reduce-date option expects \"yes\", or \"no\" as value"
- return $ ctx{ctx_reduce_date})
- "[yes|no]")
- "use advanced date reducer to speed up filtering"
- -}
- , Option "t" ["filter-transaction"]
- (ReqArg (\s ctx -> do
- filter <-
- R.runParserT_with_Error
- Filter.Read.filter_transaction
- Filter.Read.context "" s
- case filter of
- Left ko -> Write.fatal c ko
- Right flt ->
- return $
- ctx{ctx_filter_transaction =
- Filter.and (ctx_filter_transaction ctx) $
- (Filter.simplify $
- Filter.Read.get_Forall_Filter_Transaction_Decimal <$> flt)
- }) $
- C.translate c Lang.Type_Filter_Transaction) $
- C.translate c Lang.Help_Option_Filter_Transaction
- ]
-
-run :: C.Context -> [String] -> IO ()
-run c args = do
- (ctx, inputs) <- Args.parse c usage options (context, args)
- input_paths <- CLI.Env.paths c $ ctx_input ctx ++ inputs
- read_journals <- mapM (liftIO . journal_read ctx) input_paths
- case partitionEithers read_journals of
- (errs@(_:_), _journals) -> Write.fatals c errs
- ([], (journals::[Forall_Journal])) -> do
- with_color <- Write.with_color c IO.stdout
- W.displayIO IO.stdout $
- W.renderPretty with_color 1.0 maxBound $
- journal_write $ mconcat $
- Format.journal_flatten <$>
- case ctx_output_format ctx of
- Nothing -> journals
- Just f -> Format.journal_empty f:journals
-
--- * Type 'Format_Journal'
-
-type Format_Journal
- = Format
- ( JCC.Journal Journal_JCC)
- (Ledger.Journal Journal_Ledger)
-
-type Journal_JCC = Journal.Journal ( JCC.Charted JCC.Transaction)
-type Journal_Ledger = Journal.Journal (Ledger.Charted Ledger.Transaction)
-
--- * Class 'Journal'
-
-class Journal j where
- journal_write :: j -> W.Doc
-
-instance Format.Journal (JCC.Journal Journal_JCC) where
- type Journal_Format (JCC.Journal Journal_JCC) = Format_Journal
- journal_format = Format_JCC
-instance Journal (JCC.Journal Journal_JCC) where
- journal_write j =
- JCC.Write.transactions (JCC.journal_amount_styles j) $
- fmap Chart.charted $
- JCC.journal_content j
-
-instance Format.Journal (Ledger.Journal Journal_Ledger) where
- type Journal_Format (Ledger.Journal Journal_Ledger) = Format_Journal
- journal_format = Format_Ledger
-instance Journal (Ledger.Journal Journal_Ledger) where
- journal_write j =
- Ledger.write_transactions (Ledger.journal_amount_styles j) $
- fmap Chart.charted $
- Ledger.journal_content j
-
--- * Type 'Forall_Journal'
-
-data Forall_Journal
- = forall j m. ( Journal (j m)
- , Format.Journal (j m)
- , Format.Journal_Read j
- , Format.Journal_Monoid (j m)
- , Format.Journal_Format (j m) ~ Format_Journal )
- => Forall_Journal (j m)
-
-instance Format.Journal Forall_Journal where
- type Journal_Format Forall_Journal = Format_Journal
- journal_format (Forall_Journal j) = Format.journal_format j
-instance Format.Journal_Empty Forall_Journal where
- journal_empty f =
- case f of
- Format_JCC () -> Forall_Journal (mempty::JCC.Journal Journal_JCC)
- Format_Ledger () -> Forall_Journal (mempty::Ledger.Journal Journal_Ledger)
-
-instance Format.Journal_Monoid Forall_Journal where
- journal_flatten (Forall_Journal j) = Forall_Journal $ Format.journal_flatten j
- journal_fold f (Forall_Journal j) = Format.journal_fold (f . Forall_Journal) j
-instance Journal Forall_Journal where
- journal_write (Forall_Journal j) = journal_write j
-instance Monoid Forall_Journal where
- mempty = Forall_Journal (mempty::JCC.Journal Journal_JCC)
- mappend x y =
- case (mappend `on` Format.journal_format) x y of
- Format_JCC j -> Forall_Journal j
- Format_Ledger j -> Forall_Journal j
- mconcat js =
- case js of
- [] -> mempty
- j:jn -> foldl' mappend j jn
-
-type Journal_Filter transaction
- = Filter.Simplified
- (Filter.Filter_Bool
- (Filter.Filter_Transaction transaction))
-type Journal_Read_Cons txn
- = txn -> Filter.Filtered (Journal_Filter txn) txn
-
-journal_read
- :: Context -> FilePath
- -> IO (Either (Format.Message W.Doc) Forall_Journal)
-journal_read ctx =
- case ctx_input_format ctx of
- Format_JCC () ->
- let wrap (j::JCC.Journal Journal_JCC) = Forall_Journal j in
- let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
- = Filter.Filtered (ctx_filter_transaction ctx) in
- liftM ((+++) Format.Message wrap) .
- Format.journal_read cons
- Format_Ledger () ->
- let wrap (j::Ledger.Journal Journal_Ledger) = Forall_Journal j in
- let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
- = Filter.Filtered (ctx_filter_transaction ctx) in
- liftM ((+++) Format.Message wrap) .
- Format.journal_read cons
+++ /dev/null
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.CLI.Command.Journals where
-
-import Control.Arrow ((+++))
-import Control.Monad (Monad(..), mapM)
-import Control.Monad.IO.Class (liftIO)
-import Data.Either (Either(..), partitionEithers)
-import Data.Foldable (Foldable(..))
-import Data.Function (($), (.), const)
-import Data.Functor ((<$>))
-import Data.List ((++))
-import Data.Maybe (Maybe(..))
-import Data.Monoid (Monoid(..), (<>))
-import Data.String (String)
-import Prelude (Bounded(..), FilePath, IO, unlines)
-import System.Console.GetOpt
- ( ArgDescr(..)
- , OptDescr(..)
- , usageInfo )
-import qualified System.Environment as Env
-import System.Exit (exitSuccess)
-import qualified System.IO as IO
-import Text.Show (Show)
-
-import qualified Hcompta.CLI.Args as Args
-import qualified Hcompta.CLI.Context as C
-import qualified Hcompta.CLI.Env as CLI.Env
-
-import qualified Hcompta.CLI.Format as Format
-import Hcompta.CLI.Format (Format(..), Formats)
-import Hcompta.CLI.Format.Ledger ()
-import Hcompta.CLI.Format.JCC ()
-import qualified Hcompta.CLI.Lang as Lang
-import qualified Hcompta.CLI.Write as Write
-
-
--- import qualified Hcompta.Lib.Parsec as R
-import qualified Hcompta.JCC as JCC
-import qualified Hcompta.Ledger as Ledger
-import qualified Text.WalderLeijen.ANSI.Text as W
-
-data Context
- = Context
- { ctx_input :: [FilePath]
- , ctx_input_format :: Formats
- } deriving (Show)
-
-context :: Context
-context =
- Context
- { ctx_input = []
- , ctx_input_format = mempty
- }
-
-usage :: C.Context -> IO String
-usage c = do
- bin <- Env.getProgName
- return $ unlines $
- [ C.translate c Lang.Section_Description
- , " "++C.translate c Lang.Help_Command_Journals
- , ""
- , C.translate c Lang.Section_Syntax
- , " "++bin++" journals ["++C.translate c Lang.Type_Option++"] [...]"++
- " ["++C.translate c Lang.Type_File_Journal++"] [...]"
- , ""
- , usageInfo (C.translate c Lang.Section_Options) (options c)
- ]
-
-options :: C.Context -> Args.Options Context
-options c =
- [ Option "h" ["help"]
- (NoArg (\_ctx -> do
- usage c >>= IO.hPutStr IO.stderr
- exitSuccess)) $
- C.translate c Lang.Help_Option_Help
- , Option "i" ["input"]
- (ReqArg (\s ctx ->
- return $ ctx{ctx_input=s:ctx_input ctx}) $
- C.translate c Lang.Type_File_Journal) $
- C.translate c Lang.Help_Option_Input
- , Option "f" ["input-format"]
- (OptArg (\arg ctx -> do
- ctx_input_format <- case arg of
- Nothing -> return $ Format_JCC ()
- Just "jcc" -> return $ Format_JCC ()
- Just "ledger" -> return $ Format_Ledger ()
- Just _ -> Write.fatal c $
- W.text "--input-format option expects \"jcc\", or \"ledger\" as value"
- return $ ctx{ctx_input_format})
- "[jcc|ledger]")
- "input format"
- ]
-
-run :: C.Context -> [String] -> IO ()
-run c args = do
- (ctx, inputs) <- Args.parse c usage options (context, args)
- input_paths <- CLI.Env.paths c $ ctx_input ctx ++ inputs
- read_journals <- mapM (liftIO . journal_read ctx) input_paths
- case partitionEithers read_journals of
- (errs@(_:_), _journals) -> Write.fatals c errs
- ([], journals) -> do
- with_color <- Write.with_color c IO.stdout
- W.displayIO IO.stdout $
- W.renderPretty with_color 1.0 maxBound $
- W.toDoc () $
- mconcat journals
-
--- * Class 'Journal'
-
-class
- ( Format.Journal_Monoid (j m)
- , Format.Journal_Read j
- ) => Journal j m where
- journal_files :: j m -> [FilePath]
-
--- JCC
-instance Journal JCC.Journal Journals_JCC where
- journal_files = JCC.journal_files
-
--- Ledger
-instance Journal Ledger.Journal Journals_Ledger where
- journal_files = Ledger.journal_files
-
-type Journals_JCC = ()
-type Journals_Ledger = ()
-
--- * Type 'Journals'
-
-newtype Journals =
- Journals [FilePath]
- deriving (Show)
-instance Monoid Journals where
- mempty = Journals []
- mappend (Journals x) (Journals y) =
- Journals (mappend x y)
- mconcat = foldl' mappend mempty
-instance W.ToDoc () Journals where
- toDoc () (Journals files) =
- foldr
- (\file doc -> doc <> W.toDoc () file <> W.line)
- W.empty files
-
-type Journal_Read_Cons txn = txn -> ()
-journal_read
- :: Context -> FilePath
- -> IO (Either (Format.Message W.Doc) Journals)
-journal_read ctx =
- case ctx_input_format ctx of
- Format_JCC () ->
- let wrap (j::JCC.Journal Journals_JCC) =
- Format.journal_fold journals_cons j mempty in
- let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
- = const () in
- (((+++) Format.Message wrap) <$>) .
- Format.journal_read cons
- Format_Ledger () ->
- let wrap (j::Ledger.Journal Journals_Ledger) =
- Format.journal_fold journals_cons j mempty in
- let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
- = const () in
- (((+++) Format.Message wrap) <$>) .
- Format.journal_read cons
-
-journals_cons :: Journal j m => j m -> Journals -> Journals
-journals_cons j (Journals files) =
- Journals (journal_files j ++ files)
+++ /dev/null
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.CLI.Command.Stats where
-
-import Control.Applicative (Const(..))
-import Control.Arrow ((+++))
-import Control.Monad (Monad(..), liftM, mapM)
-import Control.Monad.IO.Class (liftIO)
-import Data.Bool (Bool(..))
-import Data.Either (Either(..), partitionEithers)
-import Data.Foldable (Foldable(..))
-import Data.Function (($), (.), on)
-import Data.Functor ((<$>))
-import Data.List ((++))
-import qualified Data.List as List
-import qualified Data.Map.Strict as Map
-import Data.Maybe (Maybe(..))
-import Data.Monoid (Monoid(..), (<>))
-import Data.Text (Text)
-import Data.String (String)
-import Prelude (Bounded(..), Num(..), flip, unlines)
-import System.Console.GetOpt
- ( ArgDescr(..)
- , OptDescr(..)
- , usageInfo )
-import System.Environment as Env (getProgName)
-import System.Exit (exitSuccess)
-import qualified System.IO as IO
-import System.IO (FilePath, IO)
-
-import qualified Hcompta.Unit as Unit
-import qualified Hcompta.CLI.Args as Args
-import qualified Hcompta.CLI.Context as C
-import qualified Hcompta.CLI.Env as CLI.Env
-import Hcompta.CLI.Format.JCC ()
-import Hcompta.CLI.Format.Ledger ()
-import Hcompta.CLI.Format (Format(..), Formats)
-import qualified Hcompta.CLI.Format as Format
-import qualified Hcompta.CLI.Lang as Lang
-import qualified Hcompta.CLI.Write as Write
-import qualified Hcompta.Posting as Posting
-import qualified Hcompta.Filter as Filter
-import qualified Hcompta.Filter.Read as Filter.Read
-import qualified Hcompta.Filter.Amount as Filter.Amount
-import qualified Hcompta.Format.JCC as JCC
-import qualified Hcompta.Format.Ledger as Ledger
-import qualified Hcompta.Lib.Interval as Interval
-import qualified Hcompta.Lib.Parsec as R
-import qualified Hcompta.Lib.Leijen as W
-import qualified Hcompta.Stats as Stats
-
-data Context
- = Context
- { ctx_input :: [FilePath]
- , ctx_input_format :: Formats
- , ctx_filter_transaction :: forall t.
- ( Filter.Transaction t
- , Filter.Amount_Quantity
- (Posting.Posting_Amount
- (Filter.Transaction_Posting t))
- ~ Filter.Amount.Quantity
- ) => Journal_Filter t
- , ctx_output_format :: Maybe Formats
- }
-
-context :: Context
-context =
- Context
- { ctx_input = []
- , ctx_input_format = mempty
- , ctx_filter_transaction = Filter.Simplified $ Right True
- , ctx_output_format = Nothing
- }
-
-usage :: C.Context -> IO String
-usage c = do
- bin <- Env.getProgName
- return $ unlines $
- [ C.translate c Lang.Section_Description
- , " "++C.translate c Lang.Help_Command_Stats
- , ""
- , C.translate c Lang.Section_Syntax
- , " "++bin++" stats ["++C.translate c Lang.Type_Option++"] [...]"++
- " ["++C.translate c Lang.Type_File_Journal++"] [...]"
- , ""
- , usageInfo (C.translate c Lang.Section_Options) (options c)
- ]
-
-options :: C.Context -> Args.Options Context
-options c =
- [ Option "h" ["help"]
- (NoArg (\_ctx -> do
- usage c >>= IO.hPutStr IO.stderr
- exitSuccess)) $
- C.translate c Lang.Help_Option_Help
- , Option "i" ["input"]
- (ReqArg (\s ctx -> do
- return $ ctx{ctx_input=s:ctx_input ctx}) $
- C.translate c Lang.Type_File_Journal) $
- C.translate c Lang.Help_Option_Input
- , Option "if" ["input-format"]
- (OptArg (\arg ctx -> do
- ctx_input_format <- case arg of
- Nothing -> return $ Format_JCC ()
- Just "jcc" -> return $ Format_JCC ()
- Just "ledger" -> return $ Format_Ledger ()
- Just _ -> Write.fatal c $
- W.text "--input-format option expects \"jcc\", or \"ledger\" as value"
- return $ ctx{ctx_input_format})
- "[jcc|ledger]")
- "input format"
- , Option "of" ["output-format"]
- (OptArg (\arg ctx -> do
- ctx_output_format <- case arg of
- Nothing -> return $ Just $ Format_JCC ()
- Just "jcc" -> return $ Just $ Format_JCC ()
- Just "ledger" -> return $ Just $ Format_Ledger ()
- Just _ -> Write.fatal c $
- W.text "--output-format option expects \"jcc\", or \"ledger\" as value"
- return $ ctx{ctx_output_format})
- "[jcc|ledger]")
- "input format"
- , Option "t" ["filter-transaction"]
- (ReqArg (\s ctx -> do
- filter <-
- R.runParserT_with_Error
- Filter.Read.filter_transaction
- Filter.Read.context "" s
- case filter of
- Left ko -> Write.fatal c ko
- Right flt ->
- return $
- ctx{ctx_filter_transaction =
- Filter.and (ctx_filter_transaction ctx) $
- (Filter.simplify $
- Filter.Read.get_Forall_Filter_Transaction_Decimal <$> flt)
- }) $
- C.translate c Lang.Type_Filter_Transaction) $
- C.translate c Lang.Help_Option_Filter_Transaction
- ]
-
-run :: C.Context -> [String] -> IO ()
-run c args = do
- (ctx, inputs) <- Args.parse c usage options (context, args)
- input_paths <- CLI.Env.paths c $ ctx_input ctx ++ inputs
- read_journals <- mapM (liftIO . journal_read ctx) input_paths
- case partitionEithers read_journals of
- (errs@(_:_), _journals) -> Write.fatals c errs
- ([], (journals::[Forall_Stats])) -> do
- with_color <- Write.with_color c IO.stdout
- W.displayIO IO.stdout $
- W.renderPretty with_color 1.0 maxBound $
- stats_write c ctx $
- (Const::x -> Const x ()) $
- mconcat $ Format.journal_flatten <$>
- case ctx_output_format ctx of
- Nothing -> journals
- Just f -> Format.journal_empty f:journals
-
--- * Type 'Format_Journal'
-
-type Format_Journal
- = Format
- ( JCC.Journal Stats_JCC)
- (Ledger.Journal Stats_Ledger)
-
-type Stats_JCC = Stats.Stats ( JCC.Charted JCC.Transaction)
-type Stats_Ledger = Stats.Stats (Ledger.Charted Ledger.Transaction)
-
--- * Class 'Stats'
-
-class Stats j m where
- stats_write :: C.Context -> Context -> j m -> W.Doc
-instance
- ( Stats.Transaction t
- , t ~ (Format.Journal_Charted j) (Format.Journal_Transaction j)
- , Stats.Posting_Unit (Stats.Transaction_Posting t) ~ Format.Journal_Unit j
- , Unit.Unit (Format.Journal_Unit j)
- , Format.Journal_Content j
- , Format.Journal_Files j
- ) => Stats j (Stats.Stats t) where
- stats_write c _ctx j =
- let stats = Format.journal_content j in
- render
- [ (Lang.Header_Accounts,) . W.toDoc () $
- Map.size $ Stats.stats_accounts stats
- , (Lang.Header_Accounts_Depth,) $
- let depth = Stats.stats_accounts_depths stats in
- W.toDoc () (Interval.limit $ Interval.low depth) <>
- (W.bold $ W.dullyellow "..") <>
- W.toDoc () (Interval.limit $ Interval.high depth)
- , (Lang.Header_Transactions,) . W.toDoc () $
- Stats.stats_transactions stats
- , (Lang.Header_Transactions_Date,) $
- case Stats.stats_transactions_span stats of
- Nothing -> W.empty
- Just date ->
- W.toDoc () (Interval.limit $ Interval.low date) <>
- (W.bold $ W.dullyellow "..") <>
- W.toDoc () (Interval.limit $ Interval.high date)
- , (Lang.Header_Units,) . W.toDoc () $
- Map.size $ Map.delete Unit.unit_empty $
- Stats.stats_units stats
- , (Lang.Header_Journals,) . W.toDoc () $
- List.length $ Format.journal_files j
- , (Lang.Header_Tags,) . W.toDoc () $
- W.toDoc () (foldr (flip $ foldr (+)) 0 $
- Stats.stats_tags stats)
- , (Lang.Header_Tags_Distinct,) . W.toDoc () $
- Map.size $ Stats.stats_tags stats
- ]
- where
- render :: Lang.Translate h [Text] => [(h, W.Doc)] -> W.Doc
- render =
- foldMap $ \(h, x) ->
- W.hcat
- [ W.bold $ flip foldMap
- (C.translate c h::[Text]) $ \s ->
- W.dullblack (W.toDoc () s) <> W.dullyellow ":"
- , W.toDoc () x
- , W.line ]
-
-instance Format.Journal (JCC.Journal Stats_JCC) where
- type Journal_Format (JCC.Journal Stats_JCC) = Format_Journal
- journal_format = Format_JCC
-
-instance Format.Journal (Ledger.Journal Stats_Ledger) where
- type Journal_Format (Ledger.Journal Stats_Ledger) = Format_Journal
- journal_format = Format_Ledger
-
--- * Type 'Forall_Stats'
-
-data Forall_Stats
- = forall j m. ( Stats j m
- , Format.Journal (j m)
- , Format.Journal_Content j
- , Format.Journal_Files j
- , Format.Journal_Read j
- , Format.Journal_Monoid (j m)
- , Format.Journal_Format (j m) ~ Format_Journal )
- => Forall_Stats (j m)
-
-instance Format.Journal Forall_Stats where
- type Journal_Format Forall_Stats = Format_Journal
- journal_format (Forall_Stats j) = Format.journal_format j
-instance Format.Journal_Empty Forall_Stats where
- journal_empty f =
- case f of
- Format_JCC () -> Forall_Stats (mempty::JCC.Journal Stats_JCC)
- Format_Ledger () -> Forall_Stats (mempty::Ledger.Journal Stats_Ledger)
-
-instance Format.Journal_Monoid Forall_Stats where
- journal_flatten (Forall_Stats j) = Forall_Stats $ Format.journal_flatten j
- journal_fold f (Forall_Stats j) = Format.journal_fold (f . Forall_Stats) j
-instance Stats (Const Forall_Stats) () where
- stats_write c ctx (Const (Forall_Stats j)) = stats_write c ctx j
-instance Monoid Forall_Stats where
- mempty = Forall_Stats (mempty::JCC.Journal Stats_JCC)
- mappend x y =
- case (mappend `on` Format.journal_format) x y of
- Format_JCC j -> Forall_Stats j
- Format_Ledger j -> Forall_Stats j
- mconcat js =
- case js of
- [] -> mempty
- j:jn -> foldl' mappend j jn
-
-type Journal_Filter transaction
- = Filter.Simplified
- (Filter.Filter_Bool
- (Filter.Filter_Transaction transaction))
-type Journal_Read_Cons txn
- = txn -> Filter.Filtered (Journal_Filter txn) txn
-
-journal_read
- :: Context -> FilePath
- -> IO (Either (Format.Message W.Doc) Forall_Stats)
-journal_read ctx =
- case ctx_input_format ctx of
- Format_JCC () ->
- let wrap (j::JCC.Journal Stats_JCC) = Forall_Stats j in
- let cons :: Journal_Read_Cons (JCC.Charted JCC.Transaction)
- = Filter.Filtered (ctx_filter_transaction ctx) in
- liftM ((+++) Format.Message wrap) .
- Format.journal_read cons
- Format_Ledger () ->
- let wrap (j::Ledger.Journal Stats_Ledger) = Forall_Stats j in
- let cons :: Journal_Read_Cons (Ledger.Charted Ledger.Transaction)
- = Filter.Filtered (ctx_filter_transaction ctx) in
- liftM ((+++) Format.Message wrap) .
- Format.journal_read cons
+++ /dev/null
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
-module Hcompta.CLI.Command.Tags where
-
-import Control.DeepSeq (NFData(..))
-import Control.Monad (Monad(..), forM_, liftM, mapM)
-import Control.Monad.IO.Class (liftIO)
-import Control.Monad.Trans.Except (runExceptT)
-import Data.Bool
-import Data.Either (Either(..), partitionEithers)
-import Data.Foldable (Foldable(..))
-import Data.Functor ((<$>))
-import Data.Functor.Compose (Compose(..))
-import Data.List ((++))
-import qualified Data.List (filter)
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Data.Map
-import Data.Maybe (Maybe(..))
-import Data.Monoid (Monoid(..), (<>))
-import Data.String (String)
-import Prelude (($), (.), FilePath, Integer, IO, Num(..), flip, id, unlines)
-import Text.Show (Show(..))
-import System.Console.GetOpt
- ( ArgDescr(..)
- , OptDescr(..)
- , usageInfo )
-import System.Environment as Env (getProgName)
-import System.Exit (exitSuccess)
-import qualified System.IO as IO
-
-import qualified Hcompta.CLI.Args as Args
-import qualified Hcompta.CLI.Context as C
-import qualified Hcompta.CLI.Env as CLI.Env
-import Hcompta.CLI.Format.Ledger ()
-import qualified Hcompta.CLI.Lang as Lang
-import qualified Hcompta.CLI.Write as Write
-import qualified Hcompta.Filter as Filter
-import qualified Hcompta.Filter.Read as Filter.Read
-import qualified Hcompta.Format.Ledger as Ledger
-import qualified Hcompta.Format.Ledger.Journal as Ledger.Journal
-import qualified Hcompta.Format.Ledger.Read as Ledger.Read
-import Hcompta.Lib.Consable (Consable(..))
-import qualified Hcompta.Lib.Leijen as W
-import qualified Hcompta.Tag as Tag
-import Hcompta.Transaction (Transaction_Tags(..))
-
-data Ctx
- = Ctx
- { ctx_input :: [FilePath]
- , ctx_filter_transaction :: Filter.Simplified
- (Filter.Filter_Bool
- (Filter.Filter_Transaction
- (Ledger.Chart_With Ledger.Transaction)))
- , ctx_filter_tag :: Filter.Simplified
- Filter.Filter_Tags
- , ctx_tree :: Bool
- } deriving (Show)
-
-nil :: Ctx
-nil =
- Ctx
- { ctx_input = []
- , ctx_filter_transaction = mempty
- , ctx_filter_tag = mempty
- , ctx_tree = False
- }
-
-usage :: C.Context -> IO String
-usage c = do
- bin <- Env.getProgName
- return $ unlines $
- [ C.translate c Lang.Section_Description
- , " "++C.translate c Lang.Help_Command_Tags
- , ""
- , C.translate c Lang.Section_Syntax
- , " "++bin++" tags ["++C.translate c Lang.Type_Option++"] [...]"++
- " ["++C.translate c Lang.Type_File_Journal++"] [...]"
- , ""
- , usageInfo (C.translate c Lang.Section_Options) (options c)
- ]
-
-options :: C.Context -> Args.Options Ctx
-options c =
- [ Option "h" ["help"]
- (NoArg (\_ctx -> do
- usage c >>= IO.hPutStr IO.stderr
- exitSuccess)) $
- C.translate c Lang.Help_Option_Help
- , Option "i" ["input"]
- (ReqArg (\s ctx -> do
- return $ ctx{ctx_input=s:ctx_input ctx}) $
- C.translate c Lang.Type_File_Journal) $
- C.translate c Lang.Help_Option_Input
- , Option "t" ["transaction-filter"]
- (ReqArg (\s ctx -> do
- ctx_filter_transaction <-
- liftM ((ctx_filter_transaction ctx <>) . Filter.simplify) $
- liftIO $ Filter.Read.read Filter.Read.filter_transaction s
- >>= \f -> case f of
- Left ko -> Write.fatal c $ ko
- Right ok -> do
- Write.debug c $ "filter: transaction: " ++ show ok
- return ok
- return $ ctx{ctx_filter_transaction}) $
- C.translate c Lang.Type_Filter_Transaction) $
- C.translate c Lang.Help_Option_Filter_Transaction
- , Option "T" ["tag-filter"]
- (ReqArg (\s ctx -> do
- ctx_filter_tag <-
- liftM ((ctx_filter_tag ctx <>) . Filter.simplify) $
- liftIO $ Filter.Read.read Filter.Read.filter_tag s
- >>= \f -> case f of
- Left ko -> Write.fatal c $ ko
- Right ok -> do
- Write.debug c $ "filter: tag: " ++ show ok
- return ok
- return $ ctx{ctx_filter_tag}) $
- C.translate c Lang.Type_Filter_Tag) $
- C.translate c Lang.Help_Option_Filter_Tag
- , Option "" ["tree"]
- (OptArg (\arg ctx -> do
- ctx_tree <- case arg of
- Nothing -> return $ True
- Just "yes" -> return $ True
- Just "no" -> return $ False
- Just _ -> Write.fatal c Lang.Error_Option_Tags_Tree
- return $ ctx{ctx_tree})
- "[no|yes]") $
- C.translate c Lang.Help_Option_Tags_Tree
- ]
-
-run :: C.Context -> [String] -> IO ()
-run c args = do
- (ctx, inputs) <- Args.parse c usage options (nil, args)
- read_journals <-
- liftM Data.Either.partitionEithers $ do
- CLI.Env.paths c $ ctx_input ctx ++ inputs
- >>= do
- mapM $ \path -> do
- liftIO $ runExceptT $ Ledger.Read.file
- (Ledger.Read.context
- ( ctx_filter_transaction ctx
- , ctx_filter_tag ctx
- ) Ledger.journal)
- path
- >>= \x -> case x of
- Left ko -> return $ Left (path, ko)
- Right ok -> return $ Right ok
- case read_journals of
- (errs@(_:_), _journals) ->
- forM_ errs $ \(_path, err) -> do
- Write.fatal c $ err
- ([], journals) -> do
- let files = ledger_tags ctx journals
- Write.write c Write.style [(Write.Mode_Append, "-")] $ do
- doc_tags c ctx files
-
-ledger_tags
- :: Ctx
- -> [ Ledger.Journal (Tags (Ledger.Chart_With Ledger.Transaction)) ]
- -> Tags (Ledger.Chart_With Ledger.Transaction)
-ledger_tags _ctx =
- Data.Foldable.foldl'
- (flip $ Ledger.Journal.fold
- (\Ledger.Journal{Ledger.journal_sections=ts} ->
- mappend ts))
- mempty
-
-doc_tags
- :: C.Context
- -> Ctx
- -> Tags (Ledger.Chart_With Ledger.Transaction)
- -> W.Doc
-doc_tags _context ctx =
- (case ctx_tree ctx of
- True ->
- Data.Map.foldlWithKey
- (\doc p vs ->
- doc <> foldMap (\s -> W.dullyellow (W.toDoc () s) <> (W.bold $ W.dullblack ":")) p <>
- " (" <> (W.toDoc () (Data.Map.size vs)) <> ")" <>
- W.nest 2 (
- Data.Map.foldlWithKey
- (\doc' v vn ->
- doc' <> W.line <> W.dullred (W.toDoc () v) <>
- " (" <> (W.toDoc () vn) <> ")"
- )
- W.empty vs
- ) <> W.line
- )
- W.empty
- False ->
- Data.Map.foldlWithKey
- (\doc p vs ->
- doc <>
- Data.Map.foldlWithKey
- (\doc' v _vn ->
- doc' <>
- foldMap (\s -> W.dullyellow (W.toDoc () s) <> (W.bold $ W.dullblack ":")) p <>
- W.dullred (W.toDoc () v) <> W.line
- ) W.empty vs
- )
- W.empty
- ) .
- tags
-
--- * Requirements' interface
-
--- ** Class 'Posting'
-
-class Posting p where
- posting_account :: p -> Ledger.Account
-
-instance Posting Ledger.Posting where
- posting_account = Ledger.posting_account
-
--- ** Class 'Transaction'
-
-class
- ( Posting (Transaction_Posting t)
- , Foldable (Transaction_Postings t)
- )
- => Transaction t where
- type Transaction_Posting t
- type Transaction_Postings t :: * -> *
- -- transaction_postings :: t -> Transaction_Postings t (Transaction_Posting t)
- transaction_tags :: t -> Transaction_Tags
-
-instance Transaction Ledger.Transaction where
- type Transaction_Posting Ledger.Transaction = Ledger.Posting
- type Transaction_Postings Ledger.Transaction = Compose [] (Compose (Map Ledger.Account) [])
- transaction_tags = Ledger.transaction_tags
-
-instance Transaction (Ledger.Chart_With Ledger.Transaction) where
- type Transaction_Posting (Ledger.Chart_With Ledger.Transaction) = Transaction_Posting Ledger.Transaction
- type Transaction_Postings (Ledger.Chart_With Ledger.Transaction) = Transaction_Postings Ledger.Transaction
- transaction_tags = transaction_tags . Ledger.with_chart
-
--- * Type 'Tags'
-
-data Transaction t => Tags t
- = Tags
- { tags :: Map Tag.Path (Map Tag.Value Integer)
- }
- deriving (Show)
-
-instance Transaction t => Monoid (Tags t) where
- mempty = Tags mempty
- mappend t0 t1 =
- Tags
- { tags = Data.Map.unionWith
- (Data.Map.unionWith (+))
- (tags t0)
- (tags t1)
- }
-instance NFData t => NFData (Tags t) where
- rnf (Tags t) = rnf t
-
-instance Transaction t
- => Consable (Filter.Simplified Filter.Filter_Tags)
- Tags
- t where
- mcons f t !ts =
- let Transaction_Tags (Tag.Tags ttags) = transaction_tags t in
- case Filter.simplified f of
- Right False -> ts
- Right True -> ts{ tags = merge ttags (tags ts) }
- Left fT ->
- ts{ tags = merge
- (Data.Map.mapMaybeWithKey
- (\p vs ->
- if Filter.test fT $
- Tag.Tags $
- Data.Map.singleton p vs
- then Just $ Data.List.filter
- (\v -> Filter.test fT $
- Tag.Tags $
- Data.Map.singleton p [v]) vs
- else Nothing)
- ttags)
- (tags ts)
- }
- where
- merge
- :: Map Tag.Path [Tag.Value]
- -> Map Tag.Path (Map Tag.Value Integer)
- -> Map Tag.Path (Map Tag.Value Integer)
- merge =
- Data.Map.mergeWithKey
- (\_k x1 x2 -> Just $
- Data.Map.unionWith (+) x2 $
- Data.Map.fromListWith (+) $ (, 1) <$> x1)
- ((Data.Map.fromListWith (+) . ((, 1) <$>)) <$>)
- id
-instance
- ( Filter.Transaction t
- , Transaction t
- ) => Consable
- ( Filter.Simplified
- (Filter.Filter_Bool
- (Filter.Filter_Transaction t))
- , Filter.Simplified Filter.Filter_Tags
- )
- Tags t where
- mcons (ft, fT) t !ts =
- if Filter.test ft t
- then mcons fT t ts
- else ts
+++ /dev/null
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Hcompta.CLI.Context where
-
-import Control.Monad (Monad(..))
-import Data.Bool
-import Data.String (String)
-import Data.Eq (Eq)
-import Data.Maybe (Maybe(..))
-import Data.Ord (Ord)
-import Text.Show (Show)
-import Prelude (($), (.), Bounded(..), Enum(..), IO)
-
-import Hcompta.CLI.Lang (Lang)
-import qualified Hcompta.CLI.Lang as Lang
-
-data App = App
-
-data Context
- = Context
- { verbosity :: Verbosity
- , command :: String
- , color :: Maybe Bool
- , lang :: Lang
- } deriving (Show)
-
-context :: IO Context
-context = do
- lang <- Lang.from_Env
- return $
- Context
- { verbosity = Verbosity_Info
- , command = ""
- , color = Nothing
- , lang
- }
-
-data Verbosity
- = Verbosity_Error
- | Verbosity_Warn
- | Verbosity_Info
- | Verbosity_Debug
- deriving (Bounded, Eq, Enum, Ord, Show)
-
-translate :: Lang.Translate f t => Context -> f -> t
-translate = Lang.translate . lang
+++ /dev/null
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-module Hcompta.CLI.Convert where
-
-import Control.Applicative (Const(..))
-import Data.Bool (Bool(..), not)
-import qualified Data.Char as Char
-import Data.Decimal (Decimal)
-import Data.Function (($), (.), id)
-import Data.Functor (Functor(..), (<$>))
-import qualified Data.List as List
-import Data.List.NonEmpty (NonEmpty(..))
-import Data.Map.Strict (Map)
-import qualified Data.Map.Strict as Map
-import Data.Maybe (Maybe(..))
-import Data.Monoid (Monoid(..))
-import Data.Ord (Ord(..))
-import Data.Sequence (Seq)
-import Data.Text (Text)
-import qualified Data.Text as Text
-import Data.TreeMap.Strict (TreeMap)
-import qualified Data.TreeMap.Strict as TreeMap
-
-import qualified Hcompta as H
-import qualified Hcompta.JCC as JCC
-import qualified Hcompta.Ledger as Ledger
-
-import qualified Hcompta.Lib.Strict as Strict
-
--- * Class 'Convert'
-
--- | Generic class dedicated to transform any type
--- into another one encoding more or less
--- the same data.
-class Convert from to where
- convert :: from -> to
-
-instance Convert () () where
- convert = id
-
--- Journal
-instance
- ( Convert ledger jcc
- , Monoid jcc
- , Monoid ledger
- )
- => Convert (Ledger.Journal ledger) (JCC.Journal jcc) where
- convert Ledger.Journal{..} =
- JCC.Journal
- { JCC.journal_amount_styles = convert journal_amount_styles
- , JCC.journal_chart = convert journal_chart
- , JCC.journal_files
- , JCC.journal_includes = convert <$> journal_includes
- , JCC.journal_last_read_time
- , JCC.journal_content = convert journal_content
- }
-instance
- ( Convert jcc ledger
- , Monoid jcc
- , Monoid ledger
- )
- => Convert (JCC.Journal jcc) (Ledger.Journal ledger) where
- convert JCC.Journal{..} =
- Ledger.Journal
- { Ledger.journal_amount_styles = convert journal_amount_styles
- , Ledger.journal_chart = convert journal_chart
- , Ledger.journal_files
- , Ledger.journal_includes = convert <$> journal_includes
- , Ledger.journal_last_read_time
- , Ledger.journal_content = convert journal_content
- }
-instance Convert ledger jcc
- => Convert
- (H.Journal ledger)
- (H.Journal jcc)
- where
- convert (H.Journal j) =
- H.Journal $
- convert <$>
- Map.mapKeysMonotonic convert j
-
--- Unit
-instance Convert Ledger.Unit JCC.Unit where
- convert (Ledger.Unit u) =
- JCC.Unit $
- Text.map
- (\c -> case Char.generalCategory c of
- Char.CurrencySymbol -> c
- Char.LowercaseLetter -> c
- Char.ModifierLetter -> c
- Char.OtherLetter -> c
- Char.TitlecaseLetter -> c
- Char.UppercaseLetter -> c
- _ -> '_') u
-instance Convert JCC.Unit Ledger.Unit where
- convert (JCC.Unit u) =
- Ledger.Unit u
-
--- Account
-instance Convert H.Account_Anchor H.Account_Anchor where
- convert = id
-instance Convert H.Account_Tags H.Account_Tags where
- convert = id
-
--- Amount Style
-instance Convert Ledger.Amount_Styles JCC.Amount_Styles where
- convert (Ledger.Amount_Styles sty) =
- JCC.Amount_Styles $ convert sty
-instance Convert JCC.Amount_Styles Ledger.Amount_Styles where
- convert (JCC.Amount_Styles sty) =
- Ledger.Amount_Styles $ convert sty
-instance Convert Ledger.Amount_Style JCC.Amount_Style where
- convert Ledger.Amount_Style{..} =
- JCC.Amount_Style
- { JCC.amount_style_fractioning
- , JCC.amount_style_grouping_integral =
- (<$> amount_style_grouping_integral) $
- \(Ledger.Amount_Style_Grouping c l) ->
- JCC.Amount_Style_Grouping c l
- , JCC.amount_style_grouping_fractional =
- (<$> amount_style_grouping_fractional) $
- \(Ledger.Amount_Style_Grouping c l) ->
- JCC.Amount_Style_Grouping c l
- , JCC.amount_style_unit_side =
- (<$> amount_style_unit_side) $ \s ->
- case s of
- Ledger.Amount_Style_Side_Left -> JCC.Amount_Style_Side_Left
- Ledger.Amount_Style_Side_Right -> JCC.Amount_Style_Side_Right
- , JCC.amount_style_unit_spaced
- }
-instance Convert JCC.Amount_Style Ledger.Amount_Style where
- convert JCC.Amount_Style{..} =
- Ledger.Amount_Style
- { Ledger.amount_style_fractioning
- , Ledger.amount_style_grouping_integral =
- (<$> amount_style_grouping_integral) $
- \(JCC.Amount_Style_Grouping c l) ->
- Ledger.Amount_Style_Grouping c l
- , Ledger.amount_style_grouping_fractional =
- (<$> amount_style_grouping_fractional) $
- \(JCC.Amount_Style_Grouping c l) ->
- Ledger.Amount_Style_Grouping c l
- , Ledger.amount_style_unit_side =
- (<$> amount_style_unit_side) $ \s ->
- case s of
- JCC.Amount_Style_Side_Left -> Ledger.Amount_Style_Side_Left
- JCC.Amount_Style_Side_Right -> Ledger.Amount_Style_Side_Right
- , Ledger.amount_style_unit_spaced
- }
-
--- Transaction
-instance Convert Ledger.Transaction JCC.Transaction where
- convert Ledger.Transaction{..} =
- JCC.Transaction
- { JCC.transaction_anchors = mempty
- , JCC.transaction_comments =
- List.filter (not . Text.all Char.isSpace) $
- Ledger.comments_without_tags $
- mappend
- transaction_comments_before
- transaction_comments_after
- , JCC.transaction_dates
- , JCC.transaction_postings = (convert <$>) <$> transaction_postings
- , JCC.transaction_sourcepos
- , JCC.transaction_tags =
- (case transaction_code of
- t | Text.null t -> id
- t -> H.transaction_tag_cons (H.transaction_tag ("Code":|[]) t)
- ) $
- if transaction_status
- then H.transaction_tag_cons
- (H.transaction_tag ("Status":|[]) "")
- transaction_tags
- else transaction_tags
- , JCC.transaction_wording
- }
-instance Convert JCC.Transaction Ledger.Transaction where
- convert JCC.Transaction{..} =
- let H.Transaction_Tags (H.Tags tags) = transaction_tags in
- Ledger.Transaction
- { Ledger.transaction_code = mconcat $ Map.findWithDefault [""] ("Code":|[]) tags
- , Ledger.transaction_comments_after = mempty
- , Ledger.transaction_comments_before = transaction_comments
- , Ledger.transaction_dates
- , Ledger.transaction_postings = (convert <$>) <$> transaction_postings
- , Ledger.transaction_sourcepos
- , Ledger.transaction_status =
- case Map.lookup ("Status":|[]) tags of
- Nothing -> False
- Just _ -> True
- , Ledger.transaction_tags =
- H.Transaction_Tags $ H.Tags $
- Map.delete ("Code":|[]) $
- Map.delete ("Status":|[]) $
- tags
- , Ledger.transaction_wording
- }
-
--- Posting
-instance Convert Ledger.Posting JCC.Posting where
- convert Ledger.Posting{..} =
- JCC.Posting
- { JCC.posting_account
- , JCC.posting_account_anchor = Nothing
- , JCC.posting_amounts =
- convert <$>
- Map.mapKeysMonotonic convert posting_amounts
- , JCC.posting_anchors = mempty
- , JCC.posting_comments =
- List.filter (not . Text.all Char.isSpace) $
- Ledger.comments_without_tags posting_comments
- , JCC.posting_dates
- , JCC.posting_sourcepos
- , JCC.posting_tags =
- if posting_status
- then H.posting_tag_cons
- (H.Posting_Tag $ H.tag ("Status":|[]) "")
- posting_tags
- else posting_tags
- }
-instance Convert JCC.Posting Ledger.Posting where
- convert JCC.Posting{..} =
- let H.Posting_Tags (H.Tags tags) = posting_tags in
- Ledger.Posting
- { Ledger.posting_account
- , Ledger.posting_amounts =
- convert <$>
- Map.mapKeysMonotonic convert posting_amounts
- , Ledger.posting_comments
- , Ledger.posting_dates
- , Ledger.posting_status =
- case Map.lookup ("Status":|[]) tags of
- Nothing -> False
- Just _ -> True
- , Ledger.posting_sourcepos
- , Ledger.posting_tags =
- H.Posting_Tags $ H.Tags $
- Map.delete ("Status":|[]) $
- tags
- }
-
--- Chart
-instance Convert JCC.Chart Ledger.Chart where
- convert JCC.Chart{..} =
- Ledger.Chart
- { Ledger.chart_accounts = chart_accounts
- }
-instance Convert Ledger.Chart JCC.Chart where
- convert Ledger.Chart{..} =
- JCC.Chart
- { JCC.chart_accounts = chart_accounts
- , JCC.chart_anchors = mempty
- }
-{-
-instance Convert (Chart.Chart x) (Chart.Chart x) where
- convert = id
-instance
- ( Convert (Chart.Chart a0) (Chart.Chart a1)
- , Convert x y
- ) => Convert (Chart.Charted a0 x) (Chart.Charted a1 y) where
- convert (Chart.Charted a x) =
- Chart.Charted (convert a) (convert x)
--}
-{-
-instance Convert (Chart.Chart JCC.Account) (Chart.Chart Ledger.Account) where
- convert Chart.Chart
- { Chart.chart_accounts
- , Chart.chart_anchors
- } =
- Chart.Chart
- { Chart.chart_accounts = convert chart_accounts
- , Chart.chart_anchors = convert chart_anchors
- }
--}
-
-instance Convert x y => Convert (JCC.Charted x) (Ledger.Charted y) where
- convert (JCC.Charted c x) =
- Ledger.Charted (convert c) (convert x)
-
-instance Convert x y => Convert (Ledger.Charted x) (JCC.Charted y) where
- convert (Ledger.Charted c x) =
- JCC.Charted (convert c) (convert x)
-
--- Balance
-instance
- ( Convert unit unit_
- , Convert quantity quantity_
- ) => Convert (H.Balance_by_Account_Sum unit quantity)
- (H.Balance_by_Account_Sum unit_ quantity_) where
- convert (H.Balance_by_Account_Sum m) =
- H.Balance_by_Account_Sum $
- convert <$>
- Map.mapKeysMonotonic convert m
-
--- * GL
-
--- ** Class 'GL'
-class
- ( Convert (H.Account_Section (H.Posting_Account (H.Transaction_Posting x)))
- (H.Account_Section (H.Posting_Account (H.Transaction_Posting y)))
- ) => GL x y
-instance GL JCC.Transaction Ledger.Transaction
-instance GL Ledger.Transaction JCC.Transaction
-
-instance GL ( JCC.Charted JCC.Transaction)
- (Ledger.Charted Ledger.Transaction)
-instance GL (Ledger.Charted Ledger.Transaction)
- (JCC.Charted JCC.Transaction)
-
-instance
- ( GL x y
- , GL_Line x y
- , H.GL_Transaction x
- , H.GL_Transaction y
- , Convert x y
- ) => Convert (H.GL x)
- (H.GL y) where
- convert (H.GL m)
- = H.GL $ TreeMap.map_monotonic convert (convert <$>) m
- -- NOTE: Date does not need to be converted,
- -- thus avoid a useless Map.mapKeysMonotonic
- -- from the Convert instance on Map.
-
--- *** Class 'GL_Line'
-
-class
- ( Convert (H.GL_Transaction_Line x)
- (H.GL_Transaction_Line y)
- , Convert (H.Transaction_Posting x)
- (H.Transaction_Posting y)
- , Convert (H.GL_Posting_Quantity (H.Transaction_Posting x))
- (H.GL_Posting_Quantity (H.Transaction_Posting y))
- ) => GL_Line x y
-instance GL_Line JCC.Transaction Ledger.Transaction
-instance GL_Line Ledger.Transaction JCC.Transaction
-
-instance GL_Line ( JCC.Charted JCC.Transaction)
- (Ledger.Charted Ledger.Transaction)
-instance GL_Line (Ledger.Charted Ledger.Transaction)
- (JCC.Charted JCC.Transaction)
-
-instance
- ( GL_Line x y
- , H.GL_Transaction x
- , H.GL_Transaction y
- , Convert x y
- ) => Convert (H.GL_Line x)
- (H.GL_Line y) where
- convert H.GL_Line{..} =
- H.GL_Line
- { H.gl_line_transaction = convert gl_line_transaction
- , H.gl_line_posting = convert gl_line_posting
- , H.gl_line_sum = convert gl_line_sum
- }
-
--- Class 'GL_Expanded'
-
-instance
- ( GL x y
- , GL_Line x y
- , H.GL_Transaction x
- , H.GL_Transaction y
- , Convert x y
- ) => Convert (H.GL_Expanded x)
- (H.GL_Expanded y) where
- convert (H.GL_Expanded m)
- = H.GL_Expanded $ convert m
-
--- Class 'GL_Line_Expanded'
-
-instance
- Convert x y
- => Convert (Strict.Clusive x)
- (Strict.Clusive y) where
- convert Strict.Clusive{..} =
- Strict.Clusive
- { Strict.exclusive = convert exclusive
- , Strict.inclusive = convert inclusive
- }
-
--- Const
-instance Convert x y
- => Convert (Const x w) (Const y w_) where
- convert (Const x) = Const $ convert x
-
--- Polarized
-instance
- Convert x y
- => Convert (H.Polarized x)
- (H.Polarized y) where
- convert = (convert <$>)
-
--- Date
-instance Convert H.Date H.Date where
- convert = id
-
--- Quantity
-instance Convert Decimal Decimal where
- convert = id
-
--- Text
-instance Convert Text Text where
- convert = id
-
--- List
-instance Convert x y => Convert [x] [y] where
- convert = fmap convert
-instance Convert x y => Convert (NonEmpty x) (NonEmpty y) where
- convert = fmap convert
-
--- TreeMap
-
-instance (Convert kx ky, Convert x y, Ord kx, Ord ky)
- => Convert (TreeMap kx x) (TreeMap ky y) where
- convert = TreeMap.map_monotonic convert convert
-
--- Map
-instance (Convert kx ky, Convert x y, Ord kx)
- => Convert (Map kx x) (Map ky y) where
- convert = Map.mapKeysMonotonic convert . fmap convert
-
--- Seq
-instance Convert x y => Convert (Seq x) (Seq y) where
- convert = fmap convert
-
--- * Stats
-
--- ** Class 'Stats'
-class
- ( Convert (H.Posting_Account (H.Transaction_Posting x))
- (H.Posting_Account (H.Transaction_Posting y))
- , Convert (H.Amount_Unit (H.Posting_Amount (H.Transaction_Posting x)))
- (H.Amount_Unit (H.Posting_Amount (H.Transaction_Posting y)))
- ) => Stats x y
-
-instance Stats JCC.Transaction Ledger.Transaction
-instance Stats Ledger.Transaction JCC.Transaction
-
-instance Stats ( JCC.Charted JCC.Transaction)
- (Ledger.Charted Ledger.Transaction)
-instance Stats (Ledger.Charted Ledger.Transaction)
- (JCC.Charted JCC.Transaction)
-
-instance
- ( Stats x y
- , H.Stats_Transaction x
- , H.Stats_Transaction y
- ) => Convert (H.Stats x) (H.Stats y) where
- convert s@H.Stats{..} =
- s
- { H.stats_accounts = Map.mapKeysMonotonic convert stats_accounts
- , H.stats_units = Map.mapKeysMonotonic convert stats_units
- }
+++ /dev/null
-module Hcompta.CLI.Env where
-
-import Control.Exception (tryJust)
-import Control.Monad (Monad(..), guard)
-import Data.Either (Either(..))
-import Prelude (($), (.), IO)
-import System.Environment as Env (getEnv)
-import System.IO (FilePath)
-import System.IO.Error (isDoesNotExistError)
-
-import qualified Hcompta.CLI.Context as C
-import qualified Hcompta.CLI.Lang as Lang
-import qualified Hcompta.CLI.Write as Write
-
--- | Return 'FilePath's containing 'Hcompta.Format.JCC.Journal's:
---
--- * either those given if any,
--- * or the one in HCOMPTA_JOURNAL environment variable if any,
-paths :: C.Context -> [FilePath] -> IO [FilePath]
-paths c [] = do
- x <- tryJust (guard . isDoesNotExistError) $
- Env.getEnv "HCOMPTA_JOURNAL"
- case x of
- Right ok -> return [ok]
- Left _ko -> Write.fatal c Lang.Error_No_input_file_given
-paths _c ps = return ps
+++ /dev/null
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-module Hcompta.CLI.Format where
-
-import Control.Monad.Trans.Except (runExceptT)
-import Data.Either (Either(..))
-import Data.Function (($), (.))
-import Data.Functor (Functor, (<$>))
-import Data.Monoid (Monoid(..))
-import System.IO (FilePath, IO)
-import Text.Show (Show)
-import qualified Text.Parsec.Error.Custom as R
-
-import qualified Hcompta.CLI.Lang as Lang
-import qualified Text.WalderLeijen.ANSI.Text as W
-
-import qualified Hcompta.JCC as JCC
-import qualified Hcompta.Ledger as Ledger
-
-import Hcompta.Lib.Consable (Consable)
-import qualified Hcompta.CLI.Lib.Leijen.Table as Leijen.Table
-
-import Hcompta.CLI.Convert
-
--- * Type 'Format'
-
-data Format jcc ledger
- = Format_JCC jcc
- | Format_Ledger ledger
- deriving (Show)
-type Formats = Format () ()
-
-instance
- ( Convert jcc ledger
- , Convert ledger jcc
- , Monoid jcc
- , Monoid ledger
- ) => Monoid (Format jcc ledger) where
- mempty = Format_JCC mempty
- mappend x y =
- case x of
- Format_JCC xj ->
- Format_JCC $
- case y of
- Format_JCC yj -> mappend xj yj
- Format_Ledger yj -> mappend xj (convert yj)
- Format_Ledger xj ->
- Format_Ledger $
- case y of
- Format_JCC yj -> mappend xj (convert yj)
- Format_Ledger yj -> mappend xj yj
-
-format :: Formats
-format = Format_JCC ()
-
--- * Type family 'Journal_Account'
-type family Journal_Account (j:: * -> *)
-type instance Journal_Account JCC.Journal = JCC.Account
-type instance Journal_Account Ledger.Journal = Ledger.Account
-
--- * Type family 'Journal_Account_Section'
-type family Journal_Account_Section (j:: * -> *)
-type instance Journal_Account_Section JCC.Journal = JCC.Account_Section
-type instance Journal_Account_Section Ledger.Journal = Ledger.Account_Section
-
--- * Type family 'Journal_Charted'
-type family Journal_Charted (j:: * -> *) :: * -> *
-type instance Journal_Charted JCC.Journal = JCC.Charted
-type instance Journal_Charted Ledger.Journal = Ledger.Charted
-
--- * Type family 'Journal_Quantity'
-type family Journal_Quantity (j:: * -> *)
-type instance Journal_Quantity JCC.Journal = JCC.Quantity
-type instance Journal_Quantity Ledger.Journal = Ledger.Quantity
-
--- * Type family 'Journal_Unit'
-type family Journal_Unit (j:: * -> *)
-type instance Journal_Unit JCC.Journal = JCC.Unit
-type instance Journal_Unit Ledger.Journal = Ledger.Unit
-
--- * Type family 'Journal_Posting'
-type family Journal_Posting (j:: * -> *)
-type instance Journal_Posting JCC.Journal = JCC.Posting
-type instance Journal_Posting Ledger.Journal = Ledger.Posting
-
--- * Type family 'Journal_Transaction'
-type family Journal_Transaction (j:: * -> *)
-type instance Journal_Transaction JCC.Journal = JCC.Transaction
-type instance Journal_Transaction Ledger.Journal = Ledger.Transaction
-
--- * Class 'Journal'
-
-class Journal j where
- type Journal_Format j
- journal_format
- :: j -> Journal_Format j
-
--- * Class 'Journal_Empty'
-
-class Journal_Empty j where
- journal_empty :: Formats -> j
-
--- * Class 'Journal_Files'
-
-class Journal_Files j where
- journal_files :: forall m. j m -> [FilePath]
-instance Journal_Files JCC.Journal where
- journal_files = JCC.journal_files
-instance Journal_Files Ledger.Journal where
- journal_files = Ledger.journal_files
-
--- * Class 'Journal_Read'
-
-class Journal_Read (j:: * -> *) where
- type Journal_Read_Error j
- type Journal_Read_Transaction j
- journal_read
- :: forall c m. (Monoid m, Consable c m)
- => (Journal_Read_Transaction j -> c)
- -> FilePath
- -> IO (Either (Journal_Read_Error j) (j m))
-instance Journal_Read JCC.Journal where
- type Journal_Read_Error JCC.Journal
- = [R.Error JCC.Error_Read]
- type Journal_Read_Transaction JCC.Journal
- = JCC.Charted JCC.Transaction
- journal_read cons =
- runExceptT . JCC.read_file
- (JCC.context_read cons JCC.journal)
-instance Journal_Read Ledger.Journal where
- type Journal_Read_Error Ledger.Journal
- = [R.Error Ledger.Error_Read]
- type Journal_Read_Transaction Ledger.Journal
- = Ledger.Charted Ledger.Transaction
- journal_read cons =
- runExceptT . Ledger.read_file
- (Ledger.context_read cons Ledger.journal)
-
-{-
--- * Class 'Journal_Chart'
-
-class Journal_Chart (j:: * -> *) where
- journal_chart
- :: forall m. j m
- -> Chart.Chart (NonEmpty (Journal_Account_Section j))
-instance Journal_Chart JCC.Journal where
- journal_chart = JCC.journal_chart
-instance Journal_Chart Ledger.Journal where
- journal_chart = Ledger.journal_chart
--}
-
--- * Class 'Journal_Monoid'
-
-class Journal_Monoid j where
- journal_flatten :: j -> j
- journal_fold :: (j -> a -> a) -> j -> a -> a
-instance Monoid m => Journal_Monoid (JCC.Journal m) where
- journal_flatten = JCC.journal_flatten
- journal_fold = JCC.journal_fold
-instance Monoid m => Journal_Monoid (Ledger.Journal m) where
- journal_flatten = Ledger.journal_flatten
- journal_fold = Ledger.journal_fold
-
--- * Class 'Journal_Filter'
-
-class Functor j => Journal_Filter context j m where
- journal_filter
- :: context -> j m -> j m
-
--- * Class 'Journal_Functor'
-
-class Journal_Functor x y where
- journal_functor_map :: x -> y
- journal_fmap :: forall j. Functor j => j x -> j y
- journal_fmap = (journal_functor_map <$>)
-
--- * Class 'Journal_Table'
-
--- | A class to render a journal
--- into 'Leijen.Table.Cell's.
-class Journal_Leijen_Table_Cells j m where
- journal_leijen_table_cells
- :: j m
- -> [[Leijen.Table.Cell]]
- -> [[Leijen.Table.Cell]]
-
-
--- * Class 'Journal_Wrap'
-
--- | A class dedicated to transform a journal
--- to another one using existential quantification
--- to gather multiple journals under a single type,
--- by writing instances between fully monomorphic types,
--- which ease a lot meeting the requirements
--- of the constraints in the wrap type.
-class Journal_Wrap j wrap where
- journal_wrap :: j -> wrap
-
-class Journal_Content j where
- journal_content :: forall m. j m -> m
-instance Journal_Content JCC.Journal where
- journal_content = JCC.journal_content
-instance Journal_Content Ledger.Journal where
- journal_content = Ledger.journal_content
-
--- * Type 'Message'
-
--- data Journal jnl m = forall j. jnl j => Journal (j m)
-data Message w = forall msg. Lang.Translate msg w => Message msg
-instance Lang.Translate (Message W.Doc) W.Doc where
- translate lang (Message x) = Lang.translate lang x
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.CLI.Format.JCC where
-
-import Data.Foldable (Foldable(..))
-import Data.Function (($), (.))
-import qualified Data.List as List
-import qualified Data.Text as Text
-import qualified Data.Text.Lazy as TL
-import Text.Show (Show(..))
-import Text.WalderLeijen.ANSI.Text (ToDoc(..))
-import qualified Text.WalderLeijen.ANSI.Text as W
-
-import qualified Hcompta as H
-import qualified Hcompta.JCC as JCC
-
-import qualified Hcompta.CLI.Lang as Lang
-import qualified Hcompta.CLI.Lib.Leijen.Table as Leijen.Table
-
-
-instance Lang.Translate JCC.Error_Read W.Doc where
- translate lang err =
- case err of
- JCC.Error_Read_date date -> toDoc lang date
- JCC.Error_Read_transaction_not_equilibrated styles tr unit_sums ->
- i18n_transaction_not_equilibrated styles tr unit_sums
- Lang.Error_Transaction_The_following_transaction_is_not_equilibrated_because
- JCC.Error_Read_reading_file file_path exn ->
- W.vsep $
- [ Lang.translate lang $ Lang.Error_Failed_to_read_file file_path
- , W.text $ TL.pack $ show exn
- ]
- JCC.Error_Read_including_file file_path errs ->
- W.vsep $
- [ Lang.translate lang $ Lang.Error_Failed_to_include_file file_path
- , Lang.translate lang errs
- ]
- JCC.Error_Read_account_anchor_unknown pos anchor ->
- Lang.translate lang $ Lang.Error_Account_Anchor_unknown pos anchor
- JCC.Error_Read_account_anchor_not_unique pos anchor ->
- Lang.translate lang $ Lang.Error_Account_Anchor_is_not_unique pos anchor
- where
- i18n_transaction_not_equilibrated styles tr unit_sums msg =
- W.vsep $
- [ Lang.translate lang msg
- , W.vsep $ List.map
- (\(unit, H.Balance_by_Unit_Sum{..}) ->
- Lang.translate lang $
- Lang.Error_Transaction_JCC_Unit_sums_up_to_the_non_null_amount unit $
- JCC.amount_styled styles $
- JCC.Amount unit $
- H.depolarize balance_by_unit_sum_quantity
- ) unit_sums
- , W.space
- , JCC.write_transaction styles tr
- ]
-
-instance Leijen.Table.Cell_of_forall_param JCC.Journal H.Date where
- cell_of_forall_param _ctx date =
- Leijen.Table.cell
- { Leijen.Table.cell_content = JCC.write_date date
- , Leijen.Table.cell_width = JCC.write_date_length date
- }
-instance Leijen.Table.Cell_of_forall_param JCC.Journal JCC.Account where
- cell_of_forall_param _ctx account =
- Leijen.Table.cell
- { Leijen.Table.cell_content = JCC.write_account account
- , Leijen.Table.cell_width = JCC.write_account_length account
- }
-instance Leijen.Table.Cell_of_forall_param JCC.Journal (JCC.Unit, JCC.Quantity) where
- cell_of_forall_param j (unit, qty) =
- let sty = JCC.journal_amount_styles j in
- let amt = JCC.Amount unit qty in
- let sa = JCC.amount_styled sty amt in
- Leijen.Table.cell
- { Leijen.Table.cell_content = JCC.write_amount sa
- , Leijen.Table.cell_width = JCC.write_amount_length sa
- }
-instance Leijen.Table.Cell_of_forall_param JCC.Journal JCC.Wording where
- cell_of_forall_param _j w =
- Leijen.Table.cell
- { Leijen.Table.cell_content = toDoc () w
- , Leijen.Table.cell_width = Text.length w
- }
-
-instance Foldable f => W.ToDoc1 JCC.Journal (f JCC.Transaction) where
- toDoc1 =
- JCC.write_transactions .
- JCC.journal_amount_styles
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.CLI.Format.Ledger where
-
-import Data.Foldable (Foldable(..))
-import Data.Function (($), (.))
-import qualified Data.List as List
-import qualified Data.Text as Text
-import qualified Data.Text.Lazy as TL
-import Text.Show (Show(..))
-import Text.WalderLeijen.ANSI.Text (ToDoc(..))
-import qualified Text.WalderLeijen.ANSI.Text as W
-
-import qualified Hcompta as H
-import qualified Hcompta.Ledger as Ledger
-
-import qualified Hcompta.CLI.Lang as Lang
-import qualified Hcompta.CLI.Lib.Leijen.Table as Leijen.Table
-
-instance Lang.Translate Ledger.Error_Read W.Doc where
- translate lang err =
- case err of
- Ledger.Error_Read_date date -> toDoc lang date
- Ledger.Error_Read_transaction_not_equilibrated styles tr unit_sums ->
- i18n_transaction_not_equilibrated styles tr unit_sums
- Lang.Error_Transaction_The_following_transaction_is_not_equilibrated_because
- Ledger.Error_Read_virtual_transaction_not_equilibrated styles tr unit_sums ->
- i18n_transaction_not_equilibrated styles tr unit_sums
- Lang.Error_Transaction_The_following_virtual_transaction_is_not_equilibrated_because
- Ledger.Error_Read_reading_file file_path exn ->
- W.vsep $
- [ Lang.translate lang $ Lang.Error_Failed_to_read_file file_path
- , W.text $ TL.pack $ show exn
- ]
- Ledger.Error_Read_including_file file_path errs ->
- W.vsep $
- [ Lang.translate lang $ Lang.Error_Failed_to_include_file file_path
- , Lang.translate lang errs
- ]
- where
- i18n_transaction_not_equilibrated styles tr unit_sums msg =
- W.vsep $
- [ Lang.translate lang msg
- , W.vsep $ List.map
- (\(unit, H.Balance_by_Unit_Sum{..}) ->
- Lang.translate lang $
- Lang.Error_Transaction_Ledger_Unit_sums_up_to_the_non_null_amount unit $
- Ledger.amount_styled styles $
- Ledger.Amount unit $
- H.depolarize balance_by_unit_sum_quantity
- ) unit_sums
- , W.space
- , Ledger.write_transaction styles tr
- ]
-
-instance Leijen.Table.Cell_of_forall_param Ledger.Journal H.Date where
- cell_of_forall_param _ctx date =
- Leijen.Table.cell
- { Leijen.Table.cell_content = Ledger.write_date date
- , Leijen.Table.cell_width = Ledger.write_date_length date
- }
-instance Leijen.Table.Cell_of_forall_param Ledger.Journal Ledger.Account where
- cell_of_forall_param _ctx account =
- let posting_type = Ledger.Posting_Type_Regular in
- Leijen.Table.cell
- { Leijen.Table.cell_content = Ledger.write_account posting_type account
- , Leijen.Table.cell_width = Ledger.write_account_length posting_type account
- }
-instance Leijen.Table.Cell_of_forall_param Ledger.Journal (Ledger.Unit, Ledger.Quantity) where
- cell_of_forall_param j (unit, qty) =
- let sty = Ledger.journal_amount_styles j in
- let amt = Ledger.Amount unit qty in
- let sa = Ledger.amount_styled sty amt in
- Leijen.Table.cell
- { Leijen.Table.cell_content = Ledger.write_amount sa
- , Leijen.Table.cell_width = Ledger.write_amount_length sa
- }
-instance Leijen.Table.Cell_of_forall_param Ledger.Journal Ledger.Wording where
- cell_of_forall_param _j w =
- Leijen.Table.cell
- { Leijen.Table.cell_content = toDoc () w
- , Leijen.Table.cell_width = Text.length w
- }
-
-instance Foldable f => W.ToDoc1 Ledger.Journal (f Ledger.Transaction) where
- toDoc1 =
- Ledger.write_transactions .
- Ledger.journal_amount_styles
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TupleSections #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.CLI.Lang where
-
-import qualified Data.List as List
-import Data.Maybe (catMaybes, fromMaybe)
-import qualified Data.Text as Text
-import Data.Text (Text)
-import qualified Data.Text.Lazy as TL
-import Data.Monoid ((<>))
-import Prelude hiding (error)
-import qualified System.Environment as Env
-import qualified System.IO.Memoize as IO
-import qualified Text.Parsec as Parsec
-import qualified Text.Parsec.Error as Parsec.Error
-import qualified Text.Parsec.Error.Custom as Parsec
-
-import qualified Hcompta as H
-import qualified Hcompta.Ledger as Ledger
-import qualified Hcompta.JCC as JCC
-
-import Text.WalderLeijen.ANSI.Text (ToDoc(..))
-import qualified Text.WalderLeijen.ANSI.Text as W
-
--- * Type 'Lang'
-data Lang
- = EN
- | FR
- deriving (Show)
-
--- * Class 'Translate'
-class Translate from to where
- translate :: Lang -> from -> to
-instance Translate e e where
- translate _lang = id
-
--- TODO: check that this is expected behavior
--- and portability issues.
-from_Env :: IO Lang
-from_Env = do
- io_env <- IO.once Env.getEnvironment
- (<$> io_env) $ \env ->
- fromMaybe EN $ from_Strings $
- List.concatMap
- ((\lang ->
- let short = takeWhile (/= '_') lang in
- if short == lang
- then [lang]
- else [lang, short])
- . List.takeWhile (/= '.') ) $
- catMaybes
- [ List.lookup "LC_ALL" env
- , List.lookup "LC_CTYPE" env
- , List.lookup "LANG" env
- ]
-
-from_Strings :: [String] -> Maybe Lang
-from_Strings s =
- case s of
- ("fr" :_) -> Just FR
- ("fr_FR":_) -> Just FR
- ("en" :_) -> Just EN
- ("en_US":_) -> Just EN
- (_:xs) -> from_Strings xs
- [] -> Nothing
-
-(#) :: ToDoc () a => a -> W.Doc
-(#) = toDoc ()
-
-instance ToDoc () Text where
- toDoc _ = W.strict_text
-instance ToDoc () String where
- toDoc _ = W.strict_text . Text.pack
-instance ToDoc () Int where
- toDoc _ = W.int
-instance ToDoc () Integer where
- toDoc _ = W.integer
-instance ToDoc () JCC.Unit where
- toDoc _ = JCC.write_unit
-instance ToDoc () H.Account_Anchor where
- toDoc _ = JCC.write_account_anchor
-instance ToDoc () H.Transaction_Anchor where
- toDoc _ = JCC.write_transaction_anchor
-instance ToDoc () (JCC.Amount_Styled JCC.Amount) where
- toDoc _ = JCC.write_amount
-instance ToDoc () Ledger.Unit where
- toDoc _ = Ledger.write_unit
-instance ToDoc () (Ledger.Amount_Styled Ledger.Amount) where
- toDoc _ = Ledger.write_amount
-instance ToDoc () H.Date where
- toDoc _ = JCC.write_date
-instance ToDoc Lang JCC.Error_Read_Date where
- toDoc FR e =
- case e of
- JCC.Error_Read_Date_year_or_day_is_missing ->
- "l’année ou le jour est manquant·e"
- JCC.Error_Read_Date_invalid_date (year, month, day) ->
- "date incorrecte (année " <> (#)year <> ", mois " <> (#)month <> ", jour " <> (#)day <> ")"
- JCC.Error_Read_Date_invalid_time_of_day (hour, minute, second) ->
- "heure incorrecte (heure " <> (#)hour <> ", minute " <> (#)minute <> ", seconde " <> (#)second <> ")"
- toDoc EN e =
- case e of
- JCC.Error_Read_Date_year_or_day_is_missing ->
- "year or day is missing"
- JCC.Error_Read_Date_invalid_date (year, month, day) ->
- "invalid date (year " <> (#)year <> ", month " <> (#)month <> ", day " <> (#)day <> ")"
- JCC.Error_Read_Date_invalid_time_of_day (hour, minute, second) ->
- "invalid time of day (hour " <> (#)hour <> ", minute " <> (#)minute <> ", second " <> (#)second <> ")"
-instance ToDoc Lang Ledger.Error_Read_Date where
- toDoc FR e =
- case e of
- Ledger.Error_Read_Date_year_or_day_is_missing ->
- "l’année ou le jour est manquant·e"
- Ledger.Error_Read_Date_invalid_date (year, month, day) ->
- "date incorrecte (année " <> (#)year <> ", mois " <> (#)month <> ", jour " <> (#)day <> ")"
- Ledger.Error_Read_Date_invalid_time_of_day (hour, minute, second) ->
- "heure incorrecte (heure " <> (#)hour <> ", minute " <> (#)minute <> ", seconde " <> (#)second <> ")"
- toDoc EN e =
- case e of
- Ledger.Error_Read_Date_year_or_day_is_missing ->
- "year or day is missing"
- Ledger.Error_Read_Date_invalid_date (year, month, day) ->
- "invalid date (year " <> (#)year <> ", month " <> (#)month <> ", day " <> (#)day <> ")"
- Ledger.Error_Read_Date_invalid_time_of_day (hour, minute, second) ->
- "invalid time of day (hour " <> (#)hour <> ", minute " <> (#)minute <> ", second " <> (#)second <> ")"
-{-
-instance Translate Filter.Read.Error W.Doc where
- translate lang@FR err =
- case err of
- Filter.Read.Error_Unknown -> "erreur"
- Filter.Read.Error_Filter_Date d -> toDoc lang d
- Filter.Read.Error_Filter_Date_Interval (l, h) ->
- "mauvais intervalle: (" <> toDoc () l <> ", " <> toDoc () h <> ")"
- translate lang@EN err =
- case err of
- Filter.Read.Error_Unknown -> "error"
- Filter.Read.Error_Filter_Date d -> toDoc lang d
- Filter.Read.Error_Filter_Date_Interval (l, h) ->
- "wrong interval: (" <> toDoc () l <> ", " <> toDoc () h <> ")"
--}
-
--- * Type 'Account'
-
-data Account
- = Account_Equilibrium
-instance Translate Account Ledger.Account where
- translate EN t =
- case t of
- Account_Equilibrium -> Ledger.account "Equilibrium" []
- translate FR t =
- case t of
- Account_Equilibrium -> Ledger.account "Équilibre" []
-
--- * Type 'Comment'
-
-data Comment
- = Comment_Equilibrium
-instance Translate Comment Text where
- translate EN t =
- case t of
- Comment_Equilibrium -> "Equilibrium posting"
- translate FR t =
- case t of
- Comment_Equilibrium -> "Mouvement d’équilibre"
-
--- * Type 'Description'
-
-data Description
- = Description_Exercise Exercise_OC
-data Exercise_OC
- = Exercise_Opening
- | Exercise_Closing
- deriving (Eq, Show)
-
-instance Translate Description Text where
- translate EN t =
- case t of
- Description_Exercise oc ->
- case oc of
- Exercise_Opening -> "Opening balance"
- Exercise_Closing -> "Closing balance"
- translate FR t =
- case t of
- Description_Exercise oc ->
- case oc of
- Exercise_Opening -> "Solde d’ouverture"
- Exercise_Closing -> "Solde de fermeture"
-
--- * Type 'Error'
-data Error
- = Error_Account_Anchor_is_not_unique Parsec.SourcePos H.Account_Anchor
- | Error_Account_Anchor_unknown Parsec.SourcePos H.Account_Anchor
- | Error_Failed_to_include_file FilePath
- | Error_Failed_to_read_file FilePath
- | Error_No_input_file_given
- | Error_One_command_is_required
- | Error_Option_Balance_Format
- | Error_Option_Balance_Heritage
- | Error_Option_Balance_Redundant
- | Error_Option_Balance_Total
- | Error_Option_Color
- | Error_Option_Equilibrium
- | Error_Option_Equilibrium_Credit
- | Error_Option_Equilibrium_Debit
- | Error_Option_Tags_Tree
- | Error_Option_Verbosity
- | Error_Transaction_Anchor_unknown Parsec.SourcePos H.Transaction_Anchor
- | Error_Transaction_Anchor_is_not_unique Parsec.SourcePos H.Transaction_Anchor
- | Error_Transaction_Invalid_date Integer Int Int
- | Error_Transaction_Invalid_time_of_day Int Int Integer
- | Error_Transaction_The_following_transaction_is_not_equilibrated_because
- | Error_Transaction_The_following_virtual_transaction_is_not_equilibrated_because
- | Error_Transaction_JCC_Unit_sums_up_to_the_non_null_amount JCC.Unit (JCC.Amount_Styled JCC.Amount)
- | Error_Transaction_Ledger_Unit_sums_up_to_the_non_null_amount Ledger.Unit (Ledger.Amount_Styled Ledger.Amount)
- | Error_Transaction_Year_or_day_is_missing
- | Error_Unkown_command String
-instance Translate Error W.Doc where
- translate EN t =
- case t of
- Error_Account_Anchor_is_not_unique _pos anchor -> "Account anchor is not unique: " <> (#)anchor
- Error_Account_Anchor_unknown _pos anchor -> "Account anchor unkown: " <> (#)anchor
- Error_Failed_to_read_file path -> "failed to read file: " <> (#)path
- Error_Failed_to_include_file path -> "failed to include file: " <> (#)path
- Error_No_input_file_given ->
- W.vsep
- [ "no input file given, please use:"
- , "- either -i $hcompta_journal parameter"
- , "- or HCOMPTA_JOURNAL environment variable."
- ]
- Error_One_command_is_required -> "a COMMAND is required"
- Error_Option_Balance_Format -> "--format option expects \"close\", \"open\", or \"table\" as argument"
- Error_Option_Balance_Heritage -> "--heritage option expects \"yes\" or \"no\" as argument"
- Error_Option_Balance_Redundant -> "--redundant option expects \"yes\" or \"no\" as argument"
- Error_Option_Balance_Total -> "--total option expects \"yes\" or \"no\" as argument"
- Error_Option_Color -> "--color option expects \"auto\" (default), \"yes\" or \"no\" as argument"
- Error_Option_Equilibrium -> "--eq option expects an ACCOUNT"
- Error_Option_Equilibrium_Credit -> "--eq-credit option expects an ACCOUNT"
- Error_Option_Equilibrium_Debit -> "--eq-debit option expects an ACCOUNT"
- Error_Option_Tags_Tree -> "--tree option expects \"yes\" or \"no\" as value"
- Error_Option_Verbosity -> "--verbosity option expects \"error\", \"warn\", \"info\" or \"debug\" as argument"
- Error_Transaction_Anchor_is_not_unique _pos anchor -> "Transaction anchor is not unique: " <> (#)anchor
- Error_Transaction_Anchor_unknown _pos anchor -> "Transaction anchor unknown: " <> (#)anchor
- Error_Transaction_Invalid_date year month dom ->
- "invalid date (year " <> (#)year <> ", month " <> (#)month <> ", day " <> (#)dom <> ")"
- Error_Transaction_Invalid_time_of_day hour minute second ->
- "invalid time of day (hour " <> (#)hour <> ", minute " <> (#)minute <> ", second " <> (#)second <> ")"
- Error_Transaction_The_following_transaction_is_not_equilibrated_because ->
- "the following transaction is not equilibrated, because:"
- Error_Transaction_The_following_virtual_transaction_is_not_equilibrated_because ->
- "the following virtual transaction is not equilibrated, because:"
- Error_Transaction_JCC_Unit_sums_up_to_the_non_null_amount unit amount ->
- " - " <>
- (if Text.null $ H.unit_text unit
- then "empty unit"
- else "unit " <> (#)unit) <>
- " sums up to the non-null amount: " <> (#)amount
- Error_Transaction_Ledger_Unit_sums_up_to_the_non_null_amount unit amount ->
- " - " <>
- (if Text.null $ H.unit_text unit
- then "empty unit"
- else "unit " <> (#)unit) <>
- " sums up to the non-null amount: " <> (#)amount
- Error_Transaction_Year_or_day_is_missing ->
- "year or day is missing"
- Error_Unkown_command cmd -> "unkown command: " <> (#)cmd
- translate FR t =
- case t of
- Error_Account_Anchor_is_not_unique _pos anchor -> "Ancre de Compte non-unique : " <> (#)anchor
- Error_Account_Anchor_unknown _pos anchor -> "Ancre de Compte inconnue : " <> (#)anchor
- Error_Failed_to_read_file path -> "échec de la lecture du fichier : " <> (#)path
- Error_Failed_to_include_file path -> "échec à l’inclusion du fichier : " <> (#)path
- Error_No_input_file_given ->
- W.vsep
- [ "aucun fichier d’entrée indiqué, veuillez utiliser :"
- , " - soit le paramètre -i FICHIER_DE_JOURNAL,"
- , " - soit la variable d’environnement LEDGER_FILE."
- ]
- Error_One_command_is_required -> "une COMMANDE est requise"
- Error_Option_Balance_Format -> "le paramètre --format s’attend à \"close\", \"open\" ou \"table\" comme argument"
- Error_Option_Balance_Heritage -> "le paramètre --heritage s’attend à \"yes\" ou \"no\" comme argument"
- Error_Option_Balance_Redundant -> "le paramètre --redundant s’attend à \"yes\" ou \"no\" comme argument"
- Error_Option_Balance_Total -> "le paramètre --total s’attend à \"yes\" ou \"no\" comme argument"
- Error_Option_Color -> "le paramètre --color s’attend à \"auto\" (défaut), \"yes\" ou \"no\" comme argument"
- Error_Option_Equilibrium -> "le paramètre --eq s’attend à un COMPTE"
- Error_Option_Equilibrium_Credit -> "le paramètre --eq-credit s’attend à un COMPTE"
- Error_Option_Equilibrium_Debit -> "le paramètre --eq-debit s’attend à un COMPTE"
- Error_Option_Tags_Tree -> "le paramètre --total s’attend à \"yes\" ou \"no\" comme argument"
- Error_Option_Verbosity -> "le paramètre --verbosity s’attend à \"error\", \"warn\", \"info\", or \"debug\" comme argument"
- Error_Transaction_Anchor_is_not_unique _pos anchor -> "Ancre d’Écriture non-unique : " <> (#)anchor
- Error_Transaction_Anchor_unknown _pos anchor -> "Ancre d’Écriture inconnue : " <> (#)anchor
- Error_Transaction_Invalid_date year month dom ->
- "date incorrecte (année " <> (#)year <> ", mois " <> (#)month <> ", jour " <> (#)dom <> ")"
- Error_Transaction_Invalid_time_of_day hour minute second ->
- "heure incorrecte (heure " <> (#)hour <> ", minute " <> (#)minute <> ", seconde " <> (#)second <> ")"
- Error_Transaction_The_following_transaction_is_not_equilibrated_because ->
- "la transaction suivante n’est pas équilibrée, car :"
- Error_Transaction_The_following_virtual_transaction_is_not_equilibrated_because ->
- "la transaction virtuelle suivante n’est pas équilibrée, car :"
- Error_Transaction_JCC_Unit_sums_up_to_the_non_null_amount unit amount ->
- " - l’unité " <>
- (if Text.null $ H.unit_text unit
- then "vide"
- else (#)unit) <>
- " a le solde non-nul : " <> (#)amount
- Error_Transaction_Ledger_Unit_sums_up_to_the_non_null_amount unit amount ->
- " - l’unité " <>
- (if Text.null $ H.unit_text unit
- then "vide"
- else (#)unit) <>
- " a le solde non-nul : " <> (#)amount
- Error_Transaction_Year_or_day_is_missing ->
- "l’année ou le jour est manquant-e"
- Error_Unkown_command cmd -> "commande inconnue : " <> (#)cmd
-
--- * Type 'Error_Parsec'
-data Error_Parsec
- = Error_Parsec_Expect W.Doc
- | Error_Parsec_Message String
- | Error_Parsec_Or
- | Error_Parsec_Sysunexpect String
- | Error_Parsec_Sysunexpect_EOI
- | Error_Parsec_Unexpect W.Doc
- | Error_Parsec_Unknown
-instance ToDoc Lang Error_Parsec where
- toDoc EN t =
- case t of
- Error_Parsec_Expect doc -> "but expect : " <> (#)doc
- Error_Parsec_Message doc -> (#)doc
- Error_Parsec_Or -> "or"
- Error_Parsec_Sysunexpect doc -> "is written : " <> (#)doc
- Error_Parsec_Sysunexpect_EOI -> "end of file unexpected"
- Error_Parsec_Unexpect doc -> "found : " <> (#)doc
- Error_Parsec_Unknown -> "unkown"
- toDoc FR t =
- case t of
- Error_Parsec_Expect doc -> "mais s’attend à : " <> (#)doc
- Error_Parsec_Message doc -> (#)doc
- Error_Parsec_Or -> "ou"
- Error_Parsec_Sysunexpect doc -> "est écrit : " <> (#)doc
- Error_Parsec_Sysunexpect_EOI -> "fin de fichier inattendue"
- Error_Parsec_Unexpect doc -> "trouve : " <> (#)doc
- Error_Parsec_Unknown -> "inconnu"
-instance Translate Parsec.SourcePos W.Doc where
- translate EN pos = do
- let line = Parsec.sourceLine pos
- let col = Parsec.sourceColumn pos
- case Parsec.sourceName pos of
- "" -> "(line " <> (#)line <> ", column " <> (#)col <> ")"
- path -> "(line " <> (#)line <> ", column " <> (#)col <> ") in: " <> (#)path
- translate FR pos = do
- let line = Parsec.sourceLine pos
- let col = Parsec.sourceColumn pos
- case Parsec.sourceName pos of
- "" -> "(ligne " <> (#)line <> ", colonne " <> (#)col <> ")"
- path -> "(ligne " <> (#)line <> ", colonne " <> (#)col <> ") dans : " <> (#)path
-instance Translate e W.Doc
- => Translate [Parsec.Error e] W.Doc where
- translate lang errors =
- W.vsep $
- (<$> errors) $ \error ->
- case error of
- Parsec.Error_At pos errs -> W.vsep $
- [ translate lang pos
- , translate lang errs
- ]
- Parsec.Error_Parser err ->
- W.vsep $
- [ translate lang (Parsec.errorPos err)
- , showErrorMessages
- (Parsec.Error.errorMessages err)
- ]
- Parsec.Error_Custom pos err -> W.vsep $
- [ translate lang pos
- , translate lang err
- ]
- where
- showErrorMessages :: [Parsec.Error.Message] -> W.Doc
- showErrorMessages msgs
- | null msgs = toDoc lang $ Error_Parsec_Unknown
- | otherwise = W.vsep $ -- clean $
- [showSysUnExpect, showUnExpect, showExpect, showMessages]
- where
- (sysUnExpect,msgs1) = span ((Parsec.Error.SysUnExpect "") ==) msgs
- (unExpect,msgs2) = span ((Parsec.Error.UnExpect "") ==) msgs1
- (expect,messages) = span ((Parsec.Error.Expect "") ==) msgs2
-
- showExpect = showMany (Just (toDoc lang . Error_Parsec_Expect)) expect
- showUnExpect = showMany (Just (toDoc lang . Error_Parsec_Unexpect)) unExpect
- showSysUnExpect
- | not (null unExpect) || null sysUnExpect = W.empty
- | null firstMsg = toDoc lang $ Error_Parsec_Sysunexpect_EOI
- | otherwise = toDoc lang $ Error_Parsec_Sysunexpect firstMsg
- where
- firstMsg = Parsec.Error.messageString (head sysUnExpect)
-
- showMessages = showMany Nothing messages
-
- -- helpers
- showMany :: (Maybe (W.Doc -> W.Doc)) -> [Parsec.Error.Message] -> W.Doc
- showMany pre msgs_ =
- case clean (map Parsec.Error.messageString msgs_) of
- [] -> W.empty
- ms ->
- case pre of
- Nothing -> commasOr ms
- Just p -> p $ commasOr ms
-
- commasOr :: [String] -> W.Doc
- commasOr [] = W.empty
- commasOr [m] = W.bold $ W.dullblack $ W.text $ TL.pack m
- commasOr ms = commaSep (init ms)
- <> (W.space <> toDoc lang Error_Parsec_Or <> W.space)
- <> W.bold (W.dullblack $ W.text $ TL.pack $ last ms)
- commaSep = W.intercalate (W.comma <> W.space)
- (W.bold . W.dullblack . W.text . TL.pack)
- . clean
-
- clean = List.nub . filter (not . null)
-
--- * Type 'Header'
-data Header
- = Header_Accounts
- | Header_Accounts_Depth
- | Header_Journals
- | Header_Tags
- | Header_Tags_Distinct
- | Header_Transactions
- | Header_Transactions_Date
- | Header_Units
-instance Translate Header [Text] where
- translate EN t =
- case t of
- Header_Accounts -> ["Accounts"]
- Header_Accounts_Depth -> ["Accounts","Depth"]
- Header_Journals -> ["Journals"]
- Header_Tags -> ["Tags"]
- Header_Tags_Distinct -> ["Tags", "Distinct"]
- Header_Transactions -> ["Transactions"]
- Header_Transactions_Date -> ["Transactions", "Date"]
- Header_Units -> ["Unit"]
- translate FR t =
- case t of
- Header_Accounts -> ["Comptes"]
- Header_Accounts_Depth -> ["Comptes","Profondeur"]
- Header_Journals -> ["Journaux"]
- Header_Tags -> ["Tags"]
- Header_Tags_Distinct -> ["Tags", "Distincts"]
- Header_Transactions -> ["Écritures"]
- Header_Transactions_Date -> ["Écritures", "Date"]
- Header_Units -> ["Unités"]
-
--- * Type 'Help'
-data Help
- = Help_Command_Balance
- | Help_Command_General_Ledger
- | Help_Command_Journal
- | Help_Command_Journals
- | Help_Command_Stats
- | Help_Command_Tags
- | Help_Option_Balance_Format
- | Help_Option_Balance_Heritage
- | Help_Option_Balance_Redundant
- | Help_Option_Balance_Total
- | Help_Option_Color
- | Help_Option_Equilibrium
- | Help_Option_Equilibrium_Credit
- | Help_Option_Equilibrium_Debit
- | Help_Option_Filter_Balance
- | Help_Option_Filter_General_Ledger
- | Help_Option_Filter_Posting
- | Help_Option_Filter_Tag
- | Help_Option_Filter_Transaction
- | Help_Option_Help
- | Help_Option_Input
- | Help_Option_Lang
- | Help_Option_Output
- | Help_Option_Overwrite
- | Help_Option_Tags_Tree
- | Help_Option_Verbosity
- | Help_Synopsis
-instance Translate Help String where
- translate EN t =
- case t of
- Help_Command_Balance -> "List final DEBITs, CREDITs and BALANCEs of ACCOUNTs"
- Help_Command_General_Ledger -> "List DEBITs, CREDITs and BALANCEs of ACCOUNTs after each TRANSACTION"
- Help_Command_Journal -> "List TRANSACTIONs"
- Help_Command_Journals -> "List JOURNAL FILEs"
- Help_Command_Stats -> "Show some statistics"
- Help_Command_Tags -> "List TAGs"
- Help_Option_Balance_Format -> "Select BALANCE output format"
- Help_Option_Balance_Heritage -> "Propagate AMOUNTs to ascending ACCOUNTs"
- Help_Option_Balance_Redundant -> "Also show ACCOUNTs with null AMOUNT or the same AMOUNTs than its descending ACCOUNT"
- Help_Option_Balance_Total -> "Show transversal DEBIT, CREDIT, and BALANCE by UNIT"
- Help_Option_Color -> "Colorize output"
- Help_Option_Equilibrium -> "Specify the ACCOUNT equilibrating an opening or closing BALANCE"
- Help_Option_Equilibrium_Credit -> "Like --eq but only when the AMOUNT is a CREDIT"
- Help_Option_Equilibrium_Debit -> "Like --eq but only when the AMOUNT is a DEBIT"
- Help_Option_Filter_Balance -> "Apply given FILTER_OF_BALANCE, multiple uses are joined with a logical AND"
- Help_Option_Filter_General_Ledger -> "Apply given FILTER_OF_GENERAL_LEDGER, multiple uses are joined with a logical AND"
- Help_Option_Filter_Posting -> "Apply given FILTER_OF_POSTING, multiple uses are joined with a logical AND"
- Help_Option_Filter_Tag -> "Apply given FILTER_OF_TAG, multiple uses are joined with a logical AND"
- Help_Option_Filter_Transaction -> "Apply given FILTER_OF_TRANSACTION, multiple uses are joined with a logical AND"
- Help_Option_Help -> "Show this help"
- Help_Option_Input -> "Read a JOURNAL from given FILE, multiple uses merge the data"
- Help_Option_Lang -> "RFC1766 / ISO 639-1 language code (fr, en-GB, etc.)"
- Help_Option_Output -> "Append output data to given FILE, multiple uses output to multiple FILEs"
- Help_Option_Overwrite -> "Overwrite given FILE with output data, multiple uses overwrite to multiple FILEs"
- Help_Option_Tags_Tree -> "Show TAGs as a tree"
- Help_Option_Verbosity -> "Set verbosity level, or increment it when used multiple times"
- Help_Synopsis -> "[OPTIONS] COMMAND [COMMAND_OPTIONS]"
- translate FR t =
- case t of
- Help_Command_Balance -> "Liste les DÉBITs, CRÉDITs et SOLDEs finaux des COMPTEs"
- Help_Command_General_Ledger -> "Liste les DÉBITs, CRÉDITs et SOLDEs des COMPTEs après chaque ÉCRITURE"
- Help_Command_Journal -> "Liste les ÉCRITUREs"
- Help_Command_Journals -> "Liste les FICHIERs des JOURNAUX"
- Help_Command_Stats -> "Affiche quelques statistiques"
- Help_Command_Tags -> "Liste les TAGs"
- Help_Option_Balance_Format -> "Sélectionne le format de BALANCE en sortie"
- Help_Option_Balance_Heritage -> "Propage les MONTANTs aux COMPTEs ascendants"
- Help_Option_Balance_Redundant -> "Affiche également les COMPTEs dont le MONTANT est nul ou qui ont les mêmes MONTANTs que leur COMPTE descendant"
- Help_Option_Balance_Total -> "Affiche les SOLDEs transversaux par UNITÉ"
- Help_Option_Color -> "Colore la sortie"
- Help_Option_Equilibrium -> "Indique le COMPTE d’équilibre pour une BALANCE d’ouverture ou de fermeture"
- Help_Option_Equilibrium_Credit -> "Comme --eq mais seulement lorsque le MONTANT est un CRÉDIT"
- Help_Option_Equilibrium_Debit -> "Comme --eq mais seulement lorsque le MONTANT est un DÉBIT"
- Help_Option_Filter_Balance -> "Applique le FILTRE_DE_BALANCE donné, un usage multiple agit comme un ET logique"
- Help_Option_Filter_General_Ledger -> "Applique le FILTRE_DE_GRAND_LIVRE donné, un usage multiple agit comme un ET logique"
- Help_Option_Filter_Posting -> "Applique le FILTRE_DE_MOUVEMENT donné, un usage multiple agit comme un ET logique"
- Help_Option_Filter_Tag -> "Applique le FILTRE_DE_TAG donné, un usage multiple agit comme un ET logique"
- Help_Option_Filter_Transaction -> "Applique le FILTRE_D’ÉCRITURE donné, un usage multiple agit comme un ET logique"
- Help_Option_Help -> "Affiche cette aide"
- Help_Option_Input -> "Lit un JOURNAL dans le FICHIER donné, un usage multiple fusionne les données"
- Help_Option_Lang -> "Code de langue RFC1766 / ISO 639-1 language code (fr, en-GB, etc.)"
- Help_Option_Output -> "Ajoute la sortie au FICHIER donné, un usage multiple écrit dans plusieurs FICHIERs"
- Help_Option_Overwrite -> "Écrase le FICHIER donné avec la sortie, un usage multiple écrase plusieurs FICHIERs"
- Help_Option_Tags_Tree -> "Affiche les TAGs en arborescence"
- Help_Option_Verbosity -> "Indique le niveau de verbosité, ou l’incrémente lorsque utilisé plusieurs fois"
- Help_Synopsis -> "[PARAMÈTRES] COMMANDE [PARAMÈTRES_DE_COMMANDE]"
-
--- * Type 'Section'
-data Section
- = Section_Commands
- | Section_Description
- | Section_Syntax
- | Section_Options
- deriving (Eq, Show)
-instance Translate Section String where
- translate EN t =
- case t of
- Section_Commands -> "COMMANDS (use COMMAND --help for help on COMMAND)"
- Section_Description -> "DESCRIPTION"
- Section_Syntax -> "SYNTAX"
- Section_Options -> "OPTIONS"
- translate FR t =
- case t of
- Section_Commands -> "COMMANDES (utilisez COMMANDE --help pour une aide sur COMMANDE)"
- Section_Description -> "DESCRIPTION"
- Section_Syntax -> "SYNTAXE"
- Section_Options -> "PARAMÈTRES"
-
--- * Type 'Title'
-data Title
- = Title_Account
- | Title_Balance
- | Title_Credit
- | Title_Date
- | Title_Debit
- | Title_Description
- | Title_Running_balance
- | Title_Running_credit
- | Title_Running_debit
-instance Translate Title Text where
- translate EN t =
- case t of
- Title_Account -> "Account"
- Title_Balance -> "Balance"
- Title_Credit -> "Credit"
- Title_Date -> "Date"
- Title_Debit -> "Debit"
- Title_Description -> "Wording"
- Title_Running_balance -> "Running balance"
- Title_Running_credit -> "Running credit"
- Title_Running_debit -> "Running debit"
- translate FR t =
- case t of
- Title_Account -> "Compte"
- Title_Balance -> "Solde"
- Title_Credit -> "Crédit"
- Title_Date -> "Date"
- Title_Debit -> "Débit"
- Title_Description -> "Libellé"
- Title_Running_balance -> "Solde cumulé"
- Title_Running_credit -> "Crédit cumulé"
- Title_Running_debit -> "Débit cumulé"
-
--- * Type 'Type'
-data Type
- = Type_Account
- | Type_File
- | Type_File_Journal
- | Type_Filter_Balance
- | Type_Filter_General_Ledger
- | Type_Filter_Posting
- | Type_Filter_Tag
- | Type_Filter_Transaction
- | Type_Option
- deriving (Eq, Show)
-instance Translate Type String where
- translate EN t =
- case t of
- Type_Account -> "ACCOUNT"
- Type_File -> "FILE"
- Type_File_Journal -> "FILE_OF_JOURNAL"
- Type_Filter_Balance -> "FILTER_OF_BALANCE"
- Type_Filter_General_Ledger -> "FILTER_OF_GENERAL_LEDGER"
- Type_Filter_Posting -> "FILTER_OF_POSTING"
- Type_Filter_Tag -> "FILTER_OF_TAG"
- Type_Filter_Transaction -> "FILTER_OF_TRANSACTION"
- Type_Option -> "OPTION"
- translate FR t =
- case t of
- Type_Account -> "COMPTE"
- Type_File -> "FICHIER"
- Type_File_Journal -> "FICHIER_DE_JOURNAL"
- Type_Filter_Balance -> "FILTRE_DE_BALANCE"
- Type_Filter_General_Ledger -> "FILTRE_DE_GRAND_LIVRE"
- Type_Filter_Posting -> "FILTRE_DE_MOUVEMENT"
- Type_Filter_Tag -> "FILTRE_DE_TAG"
- Type_Filter_Transaction -> "FILTRE_D’ÉCRITURE"
- Type_Option -> "PARAMÈTRE"
-
--- * Type 'Write'
-data Write
- = Write_Debug
- | Write_Error
-instance Translate Write W.Doc where
- translate EN t =
- case t of
- Write_Error -> "ERROR"
- Write_Debug -> "DEBUG"
- translate FR t =
- case t of
- Write_Error -> "ERREUR"
- Write_Debug -> "DÉBUG"
-
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE Rank2Types #-}
-module Hcompta.CLI.Lib.Leijen.Table where
-
-import Data.Bool
-import Data.Char (Char)
-import qualified Data.Foldable as Foldable
-import qualified Data.List
-import Data.List (map, replicate)
-import Data.Maybe (Maybe(..), fromMaybe, maybe)
-import Data.Monoid ((<>))
-import Data.Ord (Ord(..))
-import Data.Text (Text)
-import qualified Data.Text as Text
-import qualified Data.Text.Lazy as TL
-import Prelude (($), (.), Int, Integral(..), Num(..), fromIntegral, id, zipWith)
-
-import Text.WalderLeijen.ANSI.Text (ToDoc(..))
-import qualified Text.WalderLeijen.ANSI.Text as W
-
--- * Type 'Table'
-
-type Table = [Column]
-
--- ** Class 'Table_of'
-
-class Table_of context x where
- table_of :: context -> x -> Table
-
--- * Type 'Column'
-
-data Column
- = Column
- { column_title :: Text
- , column_width :: Int
- , column_align :: Align
- , column_rows :: [Cell]
- }
-instance ToDoc () [Column] where
- toDoc _m cols =
- let rows = Data.List.transpose $ map column_rows cols in
- let has_title = Foldable.any (not . Text.null . column_title) cols in
- let titles =
- W.intercalate (W.bold $ W.dullblack $ W.char '|')
- (\col@Column{column_title} -> do
- let cell_width = Text.length column_title
- let under = W.bold $ W.dullblack $ W.char '_'
- let cell_content = W.enclose under under $
- W.hcat $ map
- (\c -> case c of { ' ' -> under; _ -> W.char c })
- (Text.unpack column_title)
- let pad len = W.bold $ W.dullblack $
- W.text $ TL.pack $ replicate len '_'
- align (Just pad) col
- Cell{cell_width, cell_content, cell_align=Just Align_Center}
- ) cols in
- W.vsep (
- (if has_title then (:) titles else id) $
- map
- ( W.intercalate (W.space <> W.bold (W.dullblack $ W.char '|')) id
- . map (W.space <>)
- . zipWith toDoc cols
- ) rows
- ) <>
- (case cols of { [] -> W.empty; _ -> W.line })
-column :: Text -> Align -> [Cell] -> Column
-column column_title column_align column_rows =
- Column
- { column_title
- , column_width = max (Text.length column_title) $
- Foldable.foldr (max . cell_width) 0 column_rows
- , column_align
- , column_rows
- }
-
--- ** Class 'Column_of'
-
-class Column_of context x where
- column_of :: context -> x -> Column
-
--- ** Type 'Align'
-
-data Align
- = Align_Left
- | Align_Center
- | Align_Right
-align :: Maybe (Int -> W.Doc) -> Column -> Cell -> W.Doc
-align filling
- Column{column_width, column_align}
- Cell{cell_width, cell_content, cell_align} =
- let pad = column_width - cell_width in
- let fill = fromMaybe (`W.fill` W.empty) filling in
- case fromMaybe column_align cell_align of
- Align_Left -> cell_content <> fill pad
- Align_Center ->
- let half = fromInteger $ quot (toInteger pad) 2 in
- fill half <> cell_content <> fill (pad - half)
- Align_Right -> fill pad <> cell_content
-align _filling
- Column{column_width}
- (Cell_Line {cell_pad}) =
- W.bold $ W.dullblack $ W.text $
- TL.replicate (fromIntegral column_width) $
- TL.singleton cell_pad
-
--- * Type 'Cell'
-
-data Cell
- = Cell
- { cell_align :: Maybe Align
- , cell_width :: Int
- , cell_content :: W.Doc
- }
- | Cell_Line
- { cell_pad :: Char
- , cell_width :: Int
- }
-cell :: Cell
-cell =
- Cell
- { cell_width = 0
- , cell_content = W.empty
- , cell_align = Nothing
- }
-instance ToDoc Column Cell where
- toDoc = align Nothing
-
--- ** Class 'Cell_of'
-
-class Cell_of context x where
- cell_of :: context -> x -> Cell
-
-instance Cell_of context x => Cell_of context (Maybe x) where
- cell_of ctx = maybe cell (cell_of ctx)
-
--- ** Class 'Cell_of_forall_param'
-
--- | A class useful when using a context of kind '*' is not wanted
--- for example in a class instance constraint
--- to keep the instance decidable (i.e. avoid UndecidableInstances).
-class Cell_of_forall_param f x where
- cell_of_forall_param :: forall m. f m -> x -> Cell
--- instance Cell_of_forall_param f x => Cell_of (f m) x where
--- cell_of = cell_of_forall_param
-instance Cell_of_forall_param context x => Cell_of_forall_param context (Maybe x) where
- cell_of_forall_param ctx = maybe cell (cell_of_forall_param ctx)
+++ /dev/null
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TupleSections #-}
-module Main (main) where
-
-import Control.Monad (Monad(..))
-import Data.Function ((.))
-import Data.Monoid ((<>))
-import qualified Data.Text.Lazy as TL
-import qualified System.Environment as Env
-import System.IO (IO)
-import qualified Text.WalderLeijen.ANSI.Text as W
-
-import qualified Hcompta.CLI.Args as Args
-import qualified Hcompta.CLI.Command as Command
-import qualified Hcompta.CLI.Context as C
-import qualified Hcompta.CLI.Lang as Lang
-import qualified Hcompta.CLI.Write as Write
-
-main :: IO ()
-main = do
- (c, cmds) <- do
- c <- C.context
- Env.getArgs >>= Args.parse c Command.usage Command.options . (c,)
- case cmds of
- cmd:args -> Command.run c cmd args
- [] -> Command.usage c
- >>= Write.fatal c .
- ((C.translate c Lang.Error_One_command_is_required <> W.line) <>) .
- W.text . TL.pack
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.CLI.Write where
-
-import Control.Monad (Monad(..), when)
-import Data.Bool
-import Data.Eq (Eq)
-import Data.Foldable (Foldable, forM_)
-import Data.List (concat)
-import Data.Maybe (Maybe(..))
-import Data.Monoid ((<>))
-import Data.Ord (Ord(..))
-import Data.String (String)
-import Prelude (($), Bounded(..), IO)
-import qualified System.Console.ANSI as ANSI
-import System.Exit (exitWith, ExitCode(..))
-import qualified System.IO as IO
-import Text.Show (Show)
-import qualified Text.WalderLeijen.ANSI.Text as W
-
-import qualified Hcompta.CLI.Context as C
-import qualified Hcompta.CLI.Lang as Lang
-
-
-with_color :: C.Context -> IO.Handle -> IO Bool
-with_color c h =
- case C.color c of
- Nothing -> IO.hIsTerminalDevice h
- Just b -> return b
-
-debug :: C.Context -> String -> IO ()
-debug c msg =
- case C.verbosity c of
- v | v >= C.Verbosity_Debug -> do
- color <- with_color c IO.stderr
- when color $ ANSI.hSetSGR IO.stderr
- [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Magenta]
- W.hPutDoc IO.stderr $ C.translate c Lang.Write_Debug
- when color $ ANSI.hSetSGR IO.stderr [ANSI.Reset]
- IO.hPutStr IO.stderr $ concat [": ", msg, "\n"]
- _ -> return ()
-
-error :: Lang.Translate msg W.Doc => C.Context -> msg -> IO ()
-error c msg =
- case C.verbosity c of
- v | v >= C.Verbosity_Error -> do
- color <- with_color c IO.stderr
- when color $ ANSI.hSetSGR IO.stderr
- [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Red]
- W.hPutDoc IO.stderr $ C.translate c Lang.Write_Error
- when color $ ANSI.hSetSGR IO.stderr [ANSI.Reset]
- W.hPutDoc IO.stderr $
- W.string ":" <> W.space <> C.translate c msg <> W.line
- _ -> return ()
-
-fatal :: Lang.Translate msg W.Doc => C.Context -> msg -> IO a
-fatal c msg = do
- error c msg
- exitWith $ ExitFailure 1
-
-fatals :: Foldable f => Lang.Translate msg W.Doc => C.Context -> f msg -> IO a
-fatals c msgs = do
- forM_ msgs $ error c
- exitWith $ ExitFailure 1
-
-data Mode
- = Mode_Over
- | Mode_Append
- deriving (Eq, Show)
-data Style
- = Style
- { style_pretty :: Bool
- }
- deriving (Eq, Show)
-
-style :: Style
-style =
- Style
- { style_pretty = True
- }
-
-write :: C.Context -> Style -> [(Mode, IO.FilePath)] -> W.Doc -> IO ()
-write context sty files doc = do
- let out =
- if style_pretty sty
- then W.renderPretty False 1.0 maxBound doc
- else W.renderCompact False doc
- let out_colored =
- if style_pretty sty
- then W.renderPretty True 1.0 maxBound doc
- else W.renderCompact True doc
- let wrt h = do
- color <- with_color context h
- if color
- then W.displayIO h out_colored
- else W.displayIO h out
- forM_ files $ \(mode, path) ->
- case path of
- "-" -> wrt IO.stdout
- _ ->
- IO.withFile path
- (case mode of
- Mode_Over -> IO.WriteMode
- Mode_Append -> IO.AppendMode)
- wrt
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
--- {-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Hcompta.Expr.Bool where
-
-import Data.Bool
--- import Data.Either (Either(..))
--- import Data.Function (($), (.))
--- import Data.Maybe (Maybe(..))
--- import Data.Monoid ((<>))
--- import Data.Proxy (Proxy(..))
--- import Data.String (String)
--- import Data.Type.Equality ((:~:)(Refl))
--- import Text.Show (Show(..))
-
-import Hcompta.Expr.Dup
--- import Hcompta.Expr.Fun
--- import Hcompta.Expr.Lit
-
--- * Class 'Expr_Bool'
-
--- | /Tagless-final symantics/ for usual logical boolean operators.
-class Expr_Bool repr where
- neg :: repr Bool -> repr Bool
- and :: repr Bool -> repr Bool -> repr Bool
- or :: repr Bool -> repr Bool -> repr Bool
- xor :: repr Bool -> repr Bool -> repr Bool
- xor x y = (x `or` y) `and` neg (x `and` y)
-
-instance -- Expr_Bool Dup
- ( Expr_Bool r1
- , Expr_Bool r2
- ) => Expr_Bool (Dup r1 r2) where
- neg (x1 `Dup` x2) = neg x1 `Dup` neg x2
- and (x1 `Dup` x2) (y1 `Dup` y2) = and x1 y1 `Dup` and x2 y2
- or (x1 `Dup` x2) (y1 `Dup` y2) = or x1 y1 `Dup` or x2 y2
-
-{-
-instance -- Expr_from Tree
- ( Expr_Bool repr
- , Type_from Tree next
- , Expr_from Tree repr next (Type_Lit Bool repr next)
- ) => Expr_from Tree repr (Type_Lit Bool repr next)
- (Type_Fun_Lit Bool repr next) where
- expr_from _pty pvar ctx (Raw "And" [raw_x, raw_y]) k =
- expr_from pvar pvar ctx raw_x $ \ty_x (x::Repr_HO repr _ctx _h_x) ->
- expr_from pvar pvar ctx raw_y $ \ty_y (y::Repr_HO repr _ctx _h_y) ->
- case (ty_x, ty_y) of
- ( Type_Fun_Next Type_Int
- , Type_Fun_Next Type_Int ) ->
- k (Type_Fun_Next Type_Int) $ \c -> and (x c) (y c)
- _ -> Left "Error: And: at least one operand is not an Int"
- expr_from _pty pvar ctx raw k =
- expr_from (Proxy::Proxy next) pvar ctx raw k
--}
-
-{-
--- * Type 'Type_Bool'
-
--- | GADT for boolean type:
---
--- * singleton (bijective mapping between Haskell type @h@ and the GADT's terms),
--- * and extensible (through @next@).
-data Type_Bool (next:: * -> *) h where
- Type_Bool :: Type_Bool next Bool
- Type_Bool_Next :: next h -> Type_Bool next h
-type Type_Fun_Lit_Bool repr next = Type_Fun repr (Type_Bool next)
-type Type_Fun_Lit_Bool_End repr = Type_Fun_Lit_Bool repr Type_Bool_End
-
-instance -- Type_Eq
- Type_Eq next =>
- Type_Eq (Type_Bool next) where
- type_eq Type_Bool
- Type_Bool = Just Refl
- type_eq (Type_Bool_Next x)
- (Type_Bool_Next y) = x `type_eq` y
- type_eq _ _ = Nothing
-instance -- Type_from Tree
- Type_from Tree next =>
- Type_from Tree (Type_Bool next) where
- type_from (Tree "Bool" []) k = k Type_Bool
- type_from raw k = type_from raw $ k . Type_Bool_Next
-instance -- From_Type String
- From_Type String next =>
- From_Type String (Type_Bool next) where
- from_type Type_Bool = "Bool"
- from_type (Type_Bool_Next t) = from_type t
---instance -- Show
--- From_Type String next =>
--- Show (Type_Bool next h) where
--- show = from_type
-
--- ** Type 'Type_Bool_End'
-
-data Type_Bool_End h where
- Type_Bool_End :: Type_Bool_End ()
-
-instance -- Type_Eq
- Type_Eq Type_Bool_End where
- type_eq Type_Bool_End
- Type_Bool_End = Just Refl
-instance -- Type_from Tree
- Type_from Tree Type_Bool_End where
- type_from _ k = k Type_Bool_End
-instance -- Expr_from Tree
- Show raw =>
- Expr_from raw repr Type_Bool_End (Type_Fun_Lit_Bool repr Type_Bool_End) where
- expr_from _pty _pvar _ctx raw _k =
- Left $ "Error: invalid: " <> show raw
-
-
-fun_lit_bool_from
- :: forall next raw repr ret.
- ( Expr_from raw repr (Type_Fun_Lit_Bool repr next) (Type_Fun_Lit_Bool repr next)
- -- , Expr_from raw repr next (Type_Fun_Lit_Bool repr next)
- , Expr_Fun repr
- , Expr_Lit repr
- , Type_from raw next
- )
- => Proxy next
- -> raw
- -> (forall h. Type_Fun_Lit_Bool repr next h -> repr h -> Either Error_Type ret)
- -> Either Error_Type ret
-fun_lit_bool_from _pty raw k =
- expr_from
- (Proxy::Proxy (Type_Fun_Lit_Bool repr next))
- (Proxy::Proxy (Type_Fun_Lit_Bool repr next))
- Context_Type_Empty raw $ \ty repr ->
- k ty $ repr Context_Type_Empty
--}
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Expr.Bool.Test where
-
-import Data.Bool (Bool(..))
-import Data.Function (($))
-
-import Hcompta.Expr.Lit
-import Hcompta.Expr.Bool
-import Hcompta.Expr.Trans
-import Hcompta.Trans.Bool.Const
-import Hcompta.Repr
-
-e1 = lit True `and` lit False
-e2 = (lit True `and` lit False) `or` (lit True `and` lit True)
-e3 = (lit True `or` lit False) `and` (lit True `or` lit True)
-e4 = lit True `and` neg (lit False)
-e5 = lit True `and` neg x
-e6 = x `xor` y
-e7 = (x `xor` y) `xor` z
-e8 = x `xor` (y `xor` lit True)
-
--- * Class 'Expr_Bool_Vars'
-
--- | A few boolean variables.
-class Expr_Bool_Vars repr where
- x :: repr Bool
- y :: repr Bool
- z :: repr Bool
-instance -- Trans_Boo_Const
- ( Expr_Bool_Vars repr
- , Expr_Lit repr
- ) => Expr_Bool_Vars (Trans_Bool_Const repr) where
- x = trans_lift x
- y = trans_lift y
- z = trans_lift z
-instance Expr_Bool_Vars Repr_Text_Write where
- x = Repr_Text_Write $ \_p _v -> "x"
- y = Repr_Text_Write $ \_p _v -> "y"
- z = Repr_Text_Write $ \_p _v -> "z"
+++ /dev/null
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Hcompta.Expr.Dup where
-
--- | Data type to duplicate an expression
--- in order to evaluate it with different interpreters.
-data Dup repr1 repr2 a
- = Dup
- { dup1 :: repr1 a
- , dup2 :: repr2 a
- }
-
-
-{-
--- * Whenever we use a value, we have to duplicate it first,
--- to leave the other copy for different interpreters
-dup_consume ev x =
- print (ev x1) >> return x2
- where (x1, x2) = duplicate x
--}
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Expr.Dup.Test where
-
-import Data.Bool (Bool(..))
-import Data.Function (($))
-
-import Hcompta.Expr.Lit
-import Hcompta.Expr.Bool
-import Hcompta.Expr.Fun
-
--- e1 :: (Boo repr, Lit repr) => repr Bool
-e1 = lit True `and` neg (lit True `and` lit True)
-e2 = let_val (lit True) $ \x -> lit True `and` x
-
+++ /dev/null
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Hcompta.Expr.Eq where
-
-import Data.Bool
-import Data.Eq (Eq(..))
-
-import Hcompta.Expr.Dup
-
--- * Class 'Expr_Eq'
-
-class Expr_Eq repr where
- eq :: Eq a => repr a -> repr a -> repr Bool
-
-instance (Expr_Eq r1, Expr_Eq r2) => Expr_Eq (Dup r1 r2) where
- eq (x1 `Dup` x2) (y1 `Dup` y2) = eq x1 y1 `Dup` eq x2 y2
+++ /dev/null
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NoImplicitPrelude #-}
--- {-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-module Hcompta.Expr.Fun where
-
-import Control.Monad (Monad(..))
-import Control.Monad.IO.Class (MonadIO(..))
-import Data.Bool
--- import Data.Either (Either(..))
--- import Data.Eq (Eq(..))
-import Data.Function (($), (.), id)
-import Data.IORef
--- import Data.Maybe (Maybe(..))
--- import Data.Monoid ((<>))
--- import Data.Proxy (Proxy(..))
--- import Data.String (String)
--- import Data.Type.Equality ((:~:)(Refl))
--- import Text.Show (Show(..))
-
-import Hcompta.Expr.Dup
-
--- * Class 'Expr_Fun'
-
--- | /Tagless-final symantics/ for /lambda abstraction/
--- in /higher-order abstract syntax/ (HOAS),
--- and with argument @arg@ and result @res@ of functions @(->)@ inside 'repr',
--- wrapped into 'repr': to control the calling.
-class Expr_Fun repr where
- default app :: Monad repr => repr (repr arg -> repr res) -> repr arg -> repr res
-
- default inline :: Monad repr => (repr arg -> repr res) -> repr (repr arg -> repr res)
- default val :: Monad repr => (repr arg -> repr res) -> repr (repr arg -> repr res)
- default lazy :: MonadIO repr => (repr arg -> repr res) -> repr (repr arg -> repr res)
-
- default let_inline :: Monad repr => repr arg -> (repr arg -> repr res) -> repr res
- default let_val :: Monad repr => repr arg -> (repr arg -> repr res) -> repr res
- default let_lazy :: MonadIO repr => repr arg -> (repr arg -> repr res) -> repr res
-
- app :: repr (repr arg -> repr res) -> repr arg -> repr res
- app x y = x >>= ($ y)
-
- -- | /call-by-name/ lambda
- inline :: (repr arg -> repr res) -> repr (repr arg -> repr res)
- inline = return
- -- | /call-by-value/ lambda
- val :: (repr arg -> repr res) -> repr (repr arg -> repr res)
- val f = return (>>= f . return)
- -- | /call-by-need/ lambda (aka. /lazyness/): lazy shares its argument, no matter what.
- lazy :: (repr arg -> repr res) -> repr (repr arg -> repr res)
- lazy f = return ((>>= f) . expr_fun_lazy_share)
-
- -- | Convenient 'inline' wrapper.
- let_inline :: repr arg -> (repr arg -> repr res) -> repr res
- let_inline x y = inline y `app` x
- -- | Convenient 'val' wrapper.
- let_val :: repr arg -> (repr arg -> repr res) -> repr res
- let_val x y = val y `app` x
- -- | Convenient 'lazy' wrapper.
- let_lazy :: repr arg -> (repr arg -> repr res) -> repr res
- let_lazy x y = lazy y `app` x
-
- ident :: repr a -> repr a
- ident = id
-
--- | Utility for storing arguments of 'lazy' into an 'IORef'.
-expr_fun_lazy_share :: MonadIO m => m a -> m (m a)
-expr_fun_lazy_share m = do
- r <- liftIO $ newIORef (False, m)
- return $ do
- (already_evaluated, m') <- liftIO $ readIORef r
- if already_evaluated
- then m'
- else do
- v <- m'
- liftIO $ writeIORef r (True, return v)
- return v
-
-instance -- Expr_Fun Dup
- ( Expr_Fun r1
- , Expr_Fun r2
- , Monad r1
- , Monad r2
- ) => Expr_Fun (Dup r1 r2) where
- app (r1_f `Dup` r2_f) (x1 `Dup` x2) =
- app (return $ \r1_a -> do
- f <- r1_f
- a <- r1_a
- dup1 $ f (r1_a `Dup` return a)) x1
- `Dup`
- app (return $ \r2_a -> do
- f <- r2_f
- a <- r2_a
- dup2 $ f (return a `Dup` r2_a)) x2
- inline f = dup1 (inline f) `Dup` dup2 (inline f)
- val f = dup1 (val f) `Dup` dup2 (val f)
- lazy f = dup1 (lazy f) `Dup` dup2 (lazy f)
- let_inline (x1 `Dup` x2) in_ =
- let_inline x1 (\r1_a -> do
- a <- r1_a
- dup1 $ in_ $ r1_a `Dup` return a)
- `Dup`
- let_inline x2 (\r2_a -> do
- a <- r2_a
- dup2 $ in_ $ return a `Dup` r2_a)
- let_val (x1 `Dup` x2) in_ =
- let_val x1 (\r1_a -> do
- a <- r1_a
- dup1 $ in_ $ r1_a `Dup` return a)
- `Dup`
- let_val x2 (\r2_a -> do
- a <- r2_a
- dup2 $ in_ $ return a `Dup` r2_a)
- let_lazy (x1 `Dup` x2) in_ =
- let_lazy x1 (\r1_a -> do
- a <- r1_a
- dup1 $ in_ $ r1_a `Dup` return a)
- `Dup`
- let_lazy x2 (\r2_a -> do
- a <- r2_a
- dup2 $ in_ $ return a `Dup` r2_a)
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Expr.Fun.Test where
-
-import Data.Bool (Bool(..))
-import Data.Function (($), id)
-
-import Hcompta.Expr.Lit
-import Hcompta.Expr.Bool
-import Hcompta.Expr.Fun
-
-e1 = val $ \x -> val $ \y -> (x `or` y) `and` neg (x `and` y)
-e2 = val $ \x -> val $ \y -> (x `and` neg y) `or` (neg x `and` y)
-e3 = let_val (lit True) $ \x -> x `and` x
-e4 = let_val (val $ \x -> x `and` x) $ \f -> f `app` lit True
-e5 = val $ \x0 -> val $ \x1 -> x0 `and` x1
-e6 = let_val (lit True) id `and` lit False
-e7 = val $ \f -> and (f `app` lit True) (lit False)
-e8 = val $ \f -> f `app` and (lit True) (lit False)
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Hcompta.Expr.If where
-
-import Control.Monad (Monad(..), when)
-import Data.Bool
-
-import Hcompta.Expr.Dup
-
--- * Class 'Expr_If'
-
-class Expr_If repr where
- default if_ :: Monad repr => repr Bool -> repr a -> repr a -> repr a
- default when_ :: Monad repr => repr Bool -> repr () -> repr ()
-
- if_ :: repr Bool -> repr a -> repr a -> repr a
- if_ m ok ko = do
- m' <- m
- if m' then ok else ko
-
- when_ :: repr Bool -> repr () -> repr ()
- when_ m ok = do
- m' <- m
- when m' ok
-
-instance -- Expr_If Dup
- ( Expr_If r1
- , Expr_If r2
- ) => Expr_If (Dup r1 r2) where
- if_ (c1 `Dup` c2) (ok1 `Dup` ok2) (ko1 `Dup` ko2) =
- if_ c1 ok1 ko1 `Dup`
- if_ c2 ok2 ko2
- when_ (c1 `Dup` c2) (ok1 `Dup` ok2) =
- when_ c1 ok1 `Dup`
- when_ c2 ok2
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Expr.If.Test where
-
-import Data.Bool (Bool(..))
-
-import Hcompta.Expr.Lit
-import Hcompta.Expr.Bool
-import Hcompta.Expr.If
-
-e1 = if_ (lit True) (lit False) (lit True)
-e2 = if_ (lit True `and` lit True) (lit False) (lit True)
+++ /dev/null
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.Expr.Lit where
-
--- import Control.Applicative (Applicative(..))
--- import Control.Monad (Monad(..))
--- import Control.Monad.Trans.State.Strict as ST
--- import Data.Bool
--- import Data.Either (Either(..))
--- import Data.Eq (Eq(..))
--- import Data.Function (($), (.))
--- import Data.Functor (Functor(..))
--- import Data.Maybe (Maybe(..))
--- import Data.Monoid ((<>))
--- import Data.Proxy (Proxy(..))
--- import Data.String (IsString(..))
--- import Data.Text (Text)
--- import qualified Data.Text as Text
-import Data.Text.Buildable (Buildable(..))
--- import Data.Type.Equality ((:~:)(Refl))
--- import GHC.Exts (IsList(..))
--- import Prelude (undefined)
--- import Text.Read (Read, reads)
-import Text.Show (Show(..))
-
--- import Hcompta.Lib.Control.Monad
--- import qualified Hcompta.Lib.Control.Monad.Classes as MC
--- import qualified Hcompta.Lib.Data.Text.Buildable as Build
-
-import Hcompta.Expr.Dup
--- import Hcompta.Expr.Fun
-
--- * Class 'Expr_Lit'
-
--- | /Tagless-final symantics/ to inject a meta-level term
--- into and object-level expression.
-class Expr_Lit repr where
- lit :: (Buildable a, Show a) => a -> repr a
-
-instance -- Expr_Lit Dup
- ( Expr_Lit r1
- , Expr_Lit r2
- ) => Expr_Lit (Dup r1 r2) where
- lit x = lit x `Dup` lit x
-
-{-
--- * Type 'Type_Lit'
-
--- | GADT for boolean type:
---
--- * singleton (bijective mapping between Haskell type @h@ and the GADT's terms),
--- * and extensible (through @next@).
-data Type_Lit lit (next:: * -> *) h where
- Type_Lit :: Type_Lit lit next lit
- Type_Lit_Next :: next h -> Type_Lit lit next h
-type Type_Fun_Lit lit repr next = Type_Fun repr (Type_Lit lit next)
-type Type_Fun_Lit_End lit repr = Type_Fun_Lit lit repr Type_Lit_End
-
-instance -- Type_Eq
- Type_Eq next =>
- Type_Eq (Type_Lit lit next) where
- type_eq Type_Lit
- Type_Lit = Just Refl
- type_eq (Type_Lit_Next x)
- (Type_Lit_Next y) = x `type_eq` y
- type_eq _ _ = Nothing
-instance -- Type_from Tree
- ( Type_from Tree next
- , Buildable (Type_Lit_Name lit)
- ) => Type_from Tree (Type_Lit lit next) where
- type_from (Tree raw_lit []) k
- | raw_lit == Build.text (Type_Lit_Name::Type_Lit_Name lit)
- = k Type_Lit
- type_from raw k = type_from raw $ k . Type_Lit_Next
-instance -- From_Type Text
- ( From_Type Text next
- , Buildable (Type_Lit_Name lit)
- ) => From_Type Text (Type_Lit lit next) where
- from_type Type_Lit = Build.text (Type_Lit_Name::Type_Lit_Name lit)
- from_type (Type_Lit_Next t) = from_type t
-instance -- Expr_from Tree
- ( Expr_Lit repr
- , Type_from Tree next
- , Expr_from Tree repr next (Type_Fun_Lit lit repr next)
- , Read lit
- , Show lit
- , Buildable lit
- , Buildable (Type_Lit_Name lit)
- ) => Expr_from Tree repr (Type_Lit lit next) (Type_Fun_Lit lit repr next) where
- expr_from _pty _pvar _ctx (Tree lit_name [Tree raw_lit []]) k
- | lit_name == Build.text (Type_Lit_Name::Type_Lit_Name lit) = do
- l <- repr_lit_read raw_lit
- k (Type_Fun_Next Type_Lit) $ \_c -> lit l
- expr_from _pty pvar ctx raw k =
- expr_from (Proxy::Proxy next) pvar ctx raw k
-
-repr_lit_read :: Read a => Text -> Either Error_Type a
-repr_lit_read t =
- let s = Text.unpack t in
- case reads s of
- [(a, "")] -> Right a
- _ -> Left $ "Read error: " <> s
-
-instance Monad m => Expr_Lit (ST.StateT s m) where
- lit = return
-instance Monad m => Expr_Lit (MC.WriterT w m) where
- lit = return
-
--- * Type 'Type_Lit_Name'
-
--- | Data type to get a name from a Haskell type-level literal type.
-data Type_Lit_Name lit = Type_Lit_Name
-instance Buildable (Type_Lit_Name Bool) where
- build _ = "Bool"
-
--- * Type 'Type_Lit_End'
-
--- | Data type to finalize a type at 'Type_Fun_Lit'.
-data Type_Lit_End h where
- Type_Lit_End :: Type_Lit_End ()
-
-instance -- Type_Eq
- Type_Eq Type_Lit_End where
- type_eq Type_Lit_End
- Type_Lit_End = Just Refl
-instance -- Type_from Tree
- Type_from Tree Type_Lit_End where
- type_from _ k = k Type_Lit_End
-instance -- Expr_from Tree
- Buildable (Type_Lit_Name lit)
- => Expr_from Tree repr Type_Lit_End (Type_Fun_Lit lit repr Type_Lit_End) where
- expr_from _pty _pvar _ctx raw _k =
- Left $ "Error: invalid Type_Lit: "
- <> Build.string (Type_Lit_Name::Type_Lit_Name lit) <> ": "
- <> show raw
--}
-
-{-
-class Literal from to where
- literal :: from -> to
-instance Applicative repr => Literal a (repr a) where
- literal = pure
-instance (Applicative repr, IsString a) => Literal String (repr a) where
- literal = pure . fromString
-instance (Applicative repr, IsString a) => Literal [String] (repr [a]) where
- literal = pure . (fromString <$>)
-instance Applicative repr => Literal [a] (repr [a]) where
- literal = pure
-instance Monad repr => Literal [repr a] (repr [a]) where
- literal = sequence
-instance Literal a a where
- literal a = a
--}
-
-{-
--- * Class 'List'
-class Monad repr => List repr where
- list :: [repr a] -> repr [a]
- list = sequence
-instance Monad m => List (ST.StateT s m)
-instance Monad m => List (WriterT w m)
-
-instance (Monad m, Monad (repr m)) => List (repr (m:: * -> *)) where
- list = sequence
--}
--- instance IsList ([a])
-
-{-
--- Orphan instances for overloading
-instance (IsList a, List (repr m)) => IsList (repr (m:: * -> *) [a]) where
- type Item (repr m [a]) = repr m a
- fromList = list
- toList = undefined
--}
-
-
-{- NOTE: conflicts with specific instance in Data.DList
-instance (IsList a, List repr) => IsList (repr [a]) where
- type Item (repr [a]) = repr a
- fromList = list
- toList = undefined
--}
-{-
-instance (Monad repr, IsString a) => IsString (repr a) where
- fromString = return . fromString
--}
+++ /dev/null
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-module Hcompta.Expr.Log where
-
-import Control.Applicative (Applicative(..))
-import Control.Monad (Monad(..))
-import Control.Monad.Catch (MonadThrow(..), MonadCatch(..), MonadMask(..))
-import qualified Control.Monad.Classes as MC
-import qualified Control.Monad.Classes.Proxied as MC
-import qualified Control.Monad.Classes.Run as MC
-import Control.Monad.IO.Class (MonadIO(..))
-import Data.Function (($), (.))
-import Data.Functor (Functor(..))
-import Data.Int (Int)
-import Data.Monoid ((<>))
-import Data.Ord (Ord(..))
-import Data.String (IsString(..))
-import Data.Text (Text)
-import Data.Text.Buildable (Buildable(..))
-import qualified Data.Time.LocalTime as Time
-import Prelude (truncate)
-
-import Hcompta.Lib.Data.Monoid (Monoid1)
-
--- * Type 'Log'
-
-data Log a
- = Log
- { log_time :: Time.ZonedTime
- , log_facility :: Log_Facility
- , log_data :: a
- } deriving (Functor)
-instance Buildable x => Buildable (Log x) where
- build Log{..} =
- let Time.TimeOfDay h m s =
- Time.localTimeOfDay $
- Time.zonedTimeToLocalTime log_time in
- "[" <> int2 h <>
- ":" <> int2 m <>
- ":" <> int2 (truncate s::Int) <>
- "] " <>
- build log_facility <> ": " <>
- build log_data
- where
- int2 i = (if i < 10 then "0" else "") <> build i
-
--- ** Type 'Log_Facility'
-data Log_Facility
- = Debug
- | Info
- | Warn
-instance Buildable Log_Facility where
- build Debug = "debug"
- build Info = "info"
- build Warn = "warn"
-
-log ::
- ( MC.MonadWriter (Log a) m
- , MonadIO m
- ) => Log_Facility -> a -> m ()
-log log_facility log_data = do
- log_time <- liftIO Time.getZonedTime
- MC.tell Log
- { log_time
- , log_facility
- , log_data
- }
-
--- * Type 'LogT'
-
--- | A 'Monad' transformer to handle different log data types,
--- eventually embedded (through class instances) into a single data type
--- put in the 'Monad' stack with 'MC.MonadWriter'.
-newtype LogT w m a = LogT (MC.CustomWriterT' (Log w) m m a)
- deriving
- ( Functor, Applicative, Monoid1
- , Monad, MonadIO, MonadThrow, MonadCatch, MonadMask)
-
-evalLogWith
- :: forall w m a . (Log w -> m ())
- -> LogT w m a
- -> m a
-evalLogWith tellFn a =
- MC.reify tellFn $ \px ->
- case a of
- LogT (MC.CustomWriterT (MC.Proxied a')) -> a' px
-
--- ** Type 'Log_Message'
-
-newtype Log_Message = Log_Message Text
-instance Buildable Log_Message where
- build (Log_Message x) = build x
-instance IsString Log_Message where
- fromString = Log_Message . fromString
+++ /dev/null
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Hcompta.Expr.Maybe where
-
-import Data.Maybe (Maybe(..))
-import Control.Monad (Monad(..))
-import Data.Function (($))
-
-import Hcompta.Expr.Dup
-
--- * Class 'Expr_Maybe'
-
-class Expr_Maybe repr where
- default may
- :: Monad repr
- => repr (Maybe a)
- -> repr b
- -> repr ((->) (repr a) (repr b))
- -> repr b
- default nothing
- :: Monad repr
- => repr (Maybe a)
- default just
- :: Monad repr
- => repr a
- -> repr (Maybe a)
-
- may
- :: repr (Maybe a)
- -> repr b
- -> repr ((->) (repr a) (repr b))
- -> repr b
- may r_m r_n r_j = do
- m <- r_m
- case m of
- Nothing -> r_n
- Just x -> do
- j <- r_j
- j (return x)
- nothing :: repr (Maybe a)
- nothing = return Nothing
- just :: repr a -> repr (Maybe a)
- just r_a = do
- a <- r_a
- return $ Just a
-
-instance -- Expr_Maybe Dup
- ( Expr_Maybe r1
- , Expr_Maybe r2
- , Monad r1
- , Monad r2
- ) => Expr_Maybe (Dup r1 r2) where
- may (m1 `Dup` m2) (n1 `Dup` n2) (r1_j `Dup` r2_j) =
- may m1 n1 (return $ \r1_a -> do
- j <- r1_j
- a <- r1_a
- dup1 $ j $ r1_a `Dup` return a)
- `Dup`
- may m2 n2 (return $ \r2_a -> do
- j <- r2_j
- a <- r2_a
- dup2 $ j $ return a `Dup` r2_a)
- nothing = nothing `Dup` nothing
- just (a1 `Dup` a2) = just (a1 `Dup` a2)
+++ /dev/null
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Hcompta.Expr.Ord where
-
-import Data.Bool
-import Data.Ord (Ord(..))
-
-import Hcompta.Expr.Bool
-import Hcompta.Expr.Eq
-import Hcompta.Expr.Dup
-
--- * Class 'Expr_Ord'
-
-class
- ( Expr_Bool repr
- , Expr_Eq repr
- ) => Expr_Ord repr where
- lt :: Ord a => repr a -> repr a -> repr Bool
-
- le :: Ord a => repr a -> repr a -> repr Bool
- le x y = (x `lt` y) `or` (x `eq` y)
-
- ge :: Ord a => repr a -> repr a -> repr Bool
- ge x y = neg (x `lt` y)
-
- gt :: Ord a => repr a -> repr a -> repr Bool
- gt x y = neg (x `le` y)
-
-instance -- Expr_Ord Dup
- ( Expr_Ord r1
- , Expr_Ord r2
- ) => Expr_Ord (Dup r1 r2) where
- lt (x1 `Dup` x2) (y1 `Dup` y2) = lt x1 y1 `Dup` lt x2 y2
- le (x1 `Dup` x2) (y1 `Dup` y2) = le x1 y1 `Dup` le x2 y2
- ge (x1 `Dup` x2) (y1 `Dup` y2) = ge x1 y1 `Dup` ge x2 y2
- gt (x1 `Dup` x2) (y1 `Dup` y2) = gt x1 y1 `Dup` gt x2 y2
+++ /dev/null
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Hcompta.Expr.Set where
-
-import Hcompta.Expr.Dup
-
--- * Class 'Expr_Set'
-
-class Expr_Set repr where
- complement :: repr a -> repr a
- intersection :: repr a -> repr a -> repr a
- union :: repr a -> repr a -> repr a
-
-instance -- Expr_Set Dup
- ( Expr_Set r1
- , Expr_Set r2
- ) => Expr_Set (Dup r1 r2) where
- complement (x1 `Dup` x2) = complement x1 `Dup` complement x2
- intersection (x1 `Dup` x2) (y1 `Dup` y2) = intersection x1 y1 `Dup` intersection x2 y2
- union (x1 `Dup` x2) (y1 `Dup` y2) = union x1 y1 `Dup` union x2 y2
+++ /dev/null
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Hcompta.Expr.Trans where
-
-import Data.Function ((.))
-
--- |
--- * 'trans_lift' is generally not /surjective/
--- * 'trans_apply' is not /injective/
--- * 'trans_apply' . 'trans_lift' == 'id'
--- * 'trans_lift' . 'trans_apply' /= 'id'
-class Trans trans repr where
- trans_lift :: repr a -> trans repr a
- trans_apply :: trans repr a -> repr a
-
- trans_map1 :: (repr a -> repr b) -> (trans repr a -> trans repr b)
- trans_map1 f = trans_lift . f . trans_apply
-
- trans_map2
- :: (repr a -> repr b -> repr c)
- -> (trans repr a -> trans repr b -> trans repr c)
- trans_map2 f e1 e2 = trans_lift (f (trans_apply e1) (trans_apply e2))
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-module Hcompta.Lib.Control.Monad where
-
-import Control.Applicative (Applicative(..))
-import Control.Monad (Monad(..), (=<<), liftM2, liftM3, liftM4, join)
-import Data.Bool
-import Data.Maybe (Maybe(..), maybe)
-
--- * 'Monad'ic utilities
-
--- | Perform some operation on 'Just', given the field inside the 'Just'.
-whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
-whenJust mg f = maybe (pure ()) f mg
-
--- | Like 'when', but where the test can be 'Monad'-ic.
-whenM :: Monad m => m Bool -> m () -> m ()
-whenM b t = ifM b t (return ())
-
--- | Like 'unless', but where the test can be 'Monad'-ic.
-unlessM :: Monad m => m Bool -> m () -> m ()
-unlessM b = ifM b (return ())
-
--- | Like @if@, but where the test can be 'Monad'-ic.
-ifM :: Monad m => m Bool -> m a -> m a -> m a
-ifM b t f = do b' <- b; if b' then t else f
-
--- | Like 'liftM' but 'join' the result of the lifted function.
-liftMJoin :: Monad m => (a -> m b) -> m a -> m b
-liftMJoin = (=<<)
-
--- | Like 'liftM2' but 'join' the result of the lifted function.
-liftM2Join :: Monad m => (a -> b -> m c) -> m a -> m b -> m c
-liftM2Join f ma mb = join (liftM2 f ma mb)
-
--- | Like 'liftM3' but 'join' the result of the lifted function.
-liftM3Join :: Monad m => (a -> b -> c -> m d) -> m a -> m b -> m c -> m d
-liftM3Join f ma mb mc = join (liftM3 f ma mb mc)
-
--- | Like 'liftM3' but 'join' the result of the lifted function.
-liftM4Join :: Monad m => (a -> b -> c -> d -> m e) -> m a -> m b -> m c -> m d -> m e
-liftM4Join f ma mb mc md = join (liftM4 f ma mb mc md)
+++ /dev/null
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.Lib.Control.Monad.Classes where
-
-import Control.Monad (Monad(..))
-import Control.Monad.Catch (MonadThrow(..), MonadCatch(..), MonadMask(..))
-import qualified Control.Monad.Classes.Proxied as MC
-import qualified Control.Monad.Classes.Run as MC
-import Data.Function (($))
-
--- * Type @Control.Monad.Classes.Writer.@'CustromWriterT' (orphan instances)
-
--- | Type synonym to @Control.Monad.Classes.Writer.@'MC.CustomWriterT'', /eta-reduced/.
-type WriterT w m = MC.CustomWriterT' w m m
-deriving instance (Monad m, MonadThrow m) => MonadThrow (WriterT w m)
-deriving instance (Monad m, MonadCatch m) => MonadCatch (WriterT w m)
-deriving instance (Monad m, MonadMask m) => MonadMask (WriterT w m)
-
--- * Type @Control.Monad.Classes.Proxied.@'MC.Proxied' (orphan instances)
-
-instance MonadThrow m => MonadThrow (MC.Proxied x m) where
- -- throwM :: Exception e => e -> m a
- throwM e = MC.Proxied (\_px -> throwM e)
-
-instance MonadCatch m => MonadCatch (MC.Proxied x m) where
- -- catch :: Exception e => m a -> (e -> m a) -> m a
- catch (MC.Proxied f) h =
- MC.Proxied $ \px ->
- f px `catch` \e ->
- case h e of
- MC.Proxied f' -> f' px
-
--- newtype Proxied x m a = Proxied (forall (q :: *). R.Reifies q x => Proxy# q -> m a)
-instance (MonadCatch m, MonadMask m) => MonadMask (MC.Proxied x m) where
- -- mask :: MonadMask m => ((forall a. m a -> m a) -> m b) -> m b
- mask restore =
- MC.Proxied $ \px ->
- mask $ \r ->
- case restore (\(MC.Proxied f) -> MC.Proxied $ \px' -> r (f px')) of
- MC.Proxied f -> f px
- -- uninterruptibleMask :: ((forall a. IO a -> IO a) -> IO b) -> IO b
- uninterruptibleMask restore =
- MC.Proxied $ \px ->
- uninterruptibleMask $ \r ->
- case restore (\(MC.Proxied f) -> MC.Proxied $ \px' -> r (f px')) of
- MC.Proxied f -> f px
+++ /dev/null
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-module Hcompta.Lib.Data.Default where
-
--- * Class 'Default'
-
-class Default a where
- def :: a
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE FlexibleInstances #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.Lib.Data.Monoid where
-
-import Control.Monad (Monad(..), liftM2)
-import Control.Monad.Trans.State.Strict as ST
-import Data.Monoid (Monoid(..))
-import qualified Hcompta.Lib.Control.Monad.Classes as MC
-import System.IO (IO)
-
--- * Class 'Monoid1' (contain orphan instances)
-
--- | 'Monoid' lifted to unary type constructor.
-class Monoid1 expr where
- mempty1 :: Monoid a => expr a
- mappend1 :: Monoid a => expr a -> expr a -> expr a
-instance Monoid1 IO where
- mempty1 = mempty
- mappend1 = mappend
-instance (Monoid1 m, Monad m) => Monoid1 (ST.StateT s m) where
- mempty1 = mempty
- mappend1 = mappend
-instance (Monad m, Monoid a) => Monoid (ST.StateT s m a) where
- mempty = return mempty
- mappend = liftM2 mappend
-instance Monoid a => Monoid (IO a) where
- mempty = return mempty
- mappend = liftM2 mappend
-instance (Monoid1 m, Monad m) => Monoid1 (MC.WriterT w m) where
- mempty1 = mempty
- mappend1 = mappend
-instance (Monad m, Monoid a) => Monoid (MC.WriterT w m a) where
- mempty = return mempty
- mappend = liftM2 mappend
-
+++ /dev/null
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.Lib.Data.Text where
-
-import Data.Char (Char)
-import Data.Eq (Eq(..))
-import qualified Data.List as List
-import Data.Maybe (Maybe(..))
-import Data.String (String)
-import Data.Text (Text)
-import qualified Data.Text as Text
-
--- * Class 'SplitOnChar'
-
-class SplitOnChar t where
- splitOnChar :: Char -> t -> [t]
-instance SplitOnChar Text where
- splitOnChar sep t =
- case Text.uncons t of
- Nothing -> []
- Just (x, xs) ->
- if x == sep
- then splitOnChar sep xs
- else
- let (chunk, rest) = Text.break (== sep) t in
- chunk:splitOnChar sep rest
-instance SplitOnChar String where
- splitOnChar sep t =
- case t of
- [] -> []
- x:xs ->
- if x == sep
- then splitOnChar sep xs
- else
- let (chunk, rest) = List.break (== sep) t in
- chunk:splitOnChar sep rest
-
--- * Class 'SplitOnCharWithEmpty'
-
-class SplitOnCharWithEmpty t where
- splitOnCharWithEmpty :: Char -> t -> [t]
-instance SplitOnCharWithEmpty Text where
- splitOnCharWithEmpty sep t =
- case Text.break (== sep) t of
- (chunk, Text.uncons -> Just (_, rest)) -> chunk : splitOnCharWithEmpty sep rest
- (chunk, _) -> [chunk]
-instance SplitOnCharWithEmpty String where
- splitOnCharWithEmpty sep t =
- case List.break (== sep) t of
- (chunk, _:rest) -> chunk : splitOnCharWithEmpty sep rest
- (chunk, []) -> [chunk]
+++ /dev/null
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Hcompta.Lib.Data.Text.Buildable where
-import Data.Function (($), (.))
-import Data.Functor ((<$>))
-import Data.Foldable (Foldable(..))
-import Data.Monoid (Monoid(..), (<>))
-import qualified Data.List as List
-import Data.String (String)
-import Data.Text (Text)
-import Data.Eq (Eq(..))
-import qualified Data.Text as Text
-import Data.Text.Buildable (Buildable(..))
-import qualified Data.Text.Lazy as TL
-import qualified Data.Text.Lazy.Builder as Build
-import Data.Text.Lazy.Builder (Builder)
-
-string :: Buildable a => a -> String
-string = TL.unpack . Build.toLazyText . build
-
-text :: Buildable a => a -> Text
-text = TL.toStrict . Build.toLazyText . build
-
-tuple :: (Foldable f, Buildable a) => f a -> Builder
-tuple f = "(" <> mconcat (List.intersperse ", " $ foldr ((:) . build) [] f) <> ")"
-
-list :: (Foldable f, Buildable a) => f a -> Builder
-list f = "[" <> mconcat (List.intersperse ", " $ foldr ((:) . build) [] f) <> "]"
-
-words :: (Foldable f, Buildable a) => f a -> Builder
-words f = mconcat (List.intersperse " " $ foldr ((:). build) [] f)
-
-words_quoted :: (Foldable f, Buildable a) => f a -> Builder
-words_quoted f =
- mconcat (List.intersperse " " $
- foldr ((:) . quote) [] f)
- where quote a =
- let t = text a in
- if Text.any (== ' ') t
- then "'"<>build t<>"'"
- else build t
-
-unlines :: (Foldable f, Buildable a) => f a -> Builder
-unlines = mconcat . List.intersperse "\n" . foldr ((:) . build) []
-
-indent :: Buildable a => Builder -> a -> Builder
-indent prefix =
- mconcat . List.intersperse "\n" .
- ((prefix <>) . build <$>) . TL.lines .
- Build.toLazyText . build
-
-parens :: Buildable a => a -> Builder
-parens a = "(" <> build a <> ")"
-
-{-
-instance Buildable a => Buildable [a] where
- build = list
--}
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Hadmin.Lib.System.File.Path where
-
-import Data.Foldable (foldMap)
-import Data.Function (($), (.))
-import Data.Functor (Functor(..), (<$>))
-import qualified Data.List as List
-import Data.Maybe (Maybe(..))
-import Data.Monoid (Monoid(..), (<>))
-import Data.String (IsString(..))
-import Data.Text (Text)
-import Data.Text.Buildable (Buildable(..))
-import GHC.Exts (IsList(..))
-import Prelude (undefined)
-import qualified System.FilePath.Posix as FP
-
-import Hadmin.Lib.Data.Text
-
--- * Type 'Path'
-type Path pos a = InPos pos (InDir a)
-
--- * Type 'Position'
-data Position = Absolute | Relative
-
--- ** Type 'SPos'
--- | Singleton type for 'Position'.
-data SPos pos where
- Abs :: SPos 'Absolute
- Rel :: SPos 'Relative
-
--- ** Type 'IPos'
-
--- | Implicit class for 'Position'.
-class IPos pos where
- pos :: SPos pos
-instance IPos 'Absolute where pos = Abs
-instance IPos 'Relative where pos = Rel
-
--- ** Type 'InPos'
-data InPos pos a = InPos (SPos pos) a
- deriving (Functor)
-instance Buildable a => Buildable (InPos pos a) where
- build (InPos Abs a) = build FP.pathSeparator <> build a
- build (InPos Rel a) = build a
-instance (IsString a, IPos pos) => IsString (InPos pos a) where
- fromString = InPos pos . fromString
-
--- ** Type 'PosOf'
-type family PosOf x :: Position
-type instance PosOf (InPos pos a) = pos
-
--- * Type 'Dir'
-
-newtype Dir = Dir [Dir_Seg]
- deriving (Monoid)
-type Dir_Seg = Text
-type AbsDir = InPos 'Absolute Dir
-type RelDir = InPos 'Relative Dir
-instance IsString Dir where
- fromString = Dir . (fromString <$>) . splitOnChar FP.pathSeparator
-instance IsList Dir where
- type Item Dir = Dir_Seg
- fromList = Dir . foldMap (splitOnChar FP.pathSeparator)
- toList (Dir d) = toList d
-instance Buildable Dir where
- build (Dir []) = "."
- build (Dir p) =
- mconcat $
- List.intersperse
- (build FP.pathSeparator)
- (build <$> p)
-
-{-
-absDir :: InPos pos a -> InPos 'Absolute a
-absDir (InPos _p a) = InPos Abs a
-
-relDir :: InPos pos a -> InPos 'Relative a
-relDir (InPos _p a) = InPos Rel a
--}
-
--- ** Type 'InDir'
-data InDir a = InDir Dir a
- deriving (Functor)
-instance IsString (a -> InDir a) where
- fromString = InDir . fromString
-instance IsString a => IsString (InDir a) where
- fromString s =
- case splitOnChar FP.pathSeparator s of
- [] -> InDir (Dir []) $ fromString ""
- l -> InDir (Dir $ fromString <$> List.init l) $ fromString (List.last l)
-instance IsList (a -> InDir a) where
- type Item (a -> InDir a) = Dir_Seg
- fromList = InDir . fromList
- toList = undefined
-instance Buildable a => Buildable (InDir a) where
- build (InDir d a) = build d <> build FP.pathSeparator <> build a
-
--- ** Class 'Dir_Parent'
-
--- | Return the parent 'Dir' of given 'Dir'
-class Dir_Parent d where
- type Dir_Parent_Dir d
- dir_parent :: d -> Maybe (Dir_Parent_Dir d)
-
-instance Dir_Parent Dir where
- type Dir_Parent_Dir Dir = Dir
- dir_parent (Dir p) =
- case p of
- [] -> Nothing
- _ -> Just $ Dir (List.init p)
-instance Dir_Parent a => Dir_Parent (InPos pos a) where
- type Dir_Parent_Dir (InPos pos a) = InPos pos (Dir_Parent_Dir a)
- dir_parent (InPos p a) = InPos p <$> dir_parent a
-instance Dir_Parent (InDir a) where
- type Dir_Parent_Dir (InDir a) = Dir
- dir_parent (InDir d _a) = Just d
-{-
-instance Dir_Parent File where
- type Dir_Parent_Dir File = Dir
- dir_parent (File _f) = Just $ Dir []
--}
-
--- ** Class 'Dir_Ancestors'
-
--- | Return self and parents 'Dir' of given 'Dir', in topological order.
-class Dir_Ancestors d where
- type Dir_Ancestors_Dir d
- dir_ancestors :: d -> [Dir_Parent_Dir d]
-
-instance Dir_Ancestors Dir where
- type Dir_Ancestors_Dir Dir = Dir
- dir_ancestors (Dir p) =
- List.reverse $
- List.foldl' (\acc seg ->
- case acc of
- [] -> [Dir [seg]]
- Dir d:_ -> Dir (d<>[seg]):acc
- ) [Dir []] p
-instance Dir_Ancestors a => Dir_Ancestors (InPos pos a) where
- type Dir_Ancestors_Dir (InPos pos a) = InPos pos (Dir_Ancestors_Dir a)
- dir_ancestors (InPos p a) = InPos p <$> dir_ancestors a
-instance Dir_Ancestors (InDir a) where
- type Dir_Ancestors_Dir (InDir a) = Dir
- dir_ancestors (InDir d _a) = dir_ancestors d
-{-
-instance Dir_Ancestors File where
- type Dir_Ancestors_Dir File = Dir
- dir_ancestors (File _f) = [Dir []]
--}
-
--- ** Class 'Dir_Append'
-class Dir_Append p q where
- type Dir_Append_Dir p q
- (</>) :: p -> q -> Dir_Append_Dir p q
-instance Dir_Append (InPos p Dir) (InPos 'Relative Dir) where
- type Dir_Append_Dir (InPos p Dir) (InPos 'Relative Dir) = InPos p Dir
- (</>) (InPos p x) (InPos _q y) = InPos p (x <> y)
-instance Dir_Append (InPos p Dir) File where
- type Dir_Append_Dir (InPos p Dir) File = InPos p (InDir File)
- (</>) (InPos p d) f = InPos p (InDir d f)
-instance Dir_Append (InPos p Dir) (InPos 'Relative (InDir a)) where
- type Dir_Append_Dir (InPos p Dir) (InPos 'Relative (InDir a)) = InPos p (InDir a)
- (</>) (InPos p x) (InPos _q (InDir y a)) = InPos p (InDir (x <> y) a)
-
--- * Type 'File'
-newtype File = File [Text]
-instance IsString File where
- fromString = File . (fromString <$>) . splitOnCharWithEmpty FP.extSeparator
-instance Buildable File where
- build (File p) =
- mconcat $
- List.intersperse
- (build FP.extSeparator)
- (build <$> p)
-
-type RelFile = InPos 'Relative (InDir File)
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE InstanceSigs #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE NoIncoherentInstances #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE NoUndecidableInstances #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Hcompta.Repr.Meta where
-
-import Control.Applicative (Applicative(..))
--- import Control.Exception.Safe (MonadThrow, MonadCatch, MonadMask)
--- import qualified Control.Exception.Safe as Exn
-import Control.Monad (Monad(..))
--- import qualified Control.Monad.Classes as MC
--- import qualified Control.Monad.Classes.Write as MC
-import Control.Monad.IO.Class (MonadIO(..))
--- import Control.Monad.Trans.Class
--- import Control.Monad.Trans.State.Strict as ST
-import Data.Bool
--- import Data.Either (Either(..))
-import Data.Eq (Eq(..))
--- import Data.Foldable (asum)
-import Data.Function (($), (.))
-import Data.Functor (Functor(..))
--- import Data.Int (Int)
--- import qualified Data.List as List
--- import Data.Maybe (Maybe(..), fromMaybe)
--- import Data.Monoid ((<>))
--- import Data.Ord (Ord(..))
--- import Data.Text (Text)
--- import qualified Data.Text as Text
--- import Data.Text.Buildable (Buildable(..))
--- import qualified Data.Text.Lazy.Builder as TL (Builder)
--- import Prelude (pred, succ)
--- import Text.Show (Show(..))
-
-import Hcompta.Expr
-import Hcompta.Lib.Control.Monad
--- import Hcompta.Lib.Data.Monoid (Monoid1)
--- import Hcompta.Lib.Data.Text as Text
-
--- * Type 'Write'
-
--- | Meta-circular /tagless-final interpreter/,
--- producing an Haskell term of type @h@.
-newtype Meta m h
- = Meta
- { unMeta :: m h }
- deriving (Applicative, Functor, Monad, MonadIO)
-
-run :: Meta m h -> m h
-run = unMeta
-
-instance Monad m => Expr_Lit (Meta m) where
- lit = Meta . return
-instance Monad m => Expr_Bool (Meta m) where
- and = liftM2Join $ \x y -> Meta $ return $ x && y
- or = liftM2Join $ \x y -> Meta $ return $ x || y
- neg = liftMJoin $ \x -> Meta $ return $ not x
-instance Monad m => Expr_Eq (Meta m) where
- eq = liftM2Join $ \x y -> Meta $ return $ x == y
-instance MonadIO m => Expr_Fun (Meta m)
+++ /dev/null
-module Repr.Test where
-
-import Test.Tasty
-import qualified Repr.Tree.Test as Text
-import qualified Repr.Text.Test as Tree
-
-tests :: TestTree
-tests =
- testGroup "Repr"
- [ Text.tests
- , Tree.tests
- ]
+++ /dev/null
-module Hcompta.Repr.Text
- ( module Hcompta.Repr.Text.Write
- ) where
-
-import Hcompta.Repr.Text.Write
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-module Repr.Text.Test where
-
-import Test.Tasty
-import qualified Repr.Text.Write.Test as Write
-
-tests :: TestTree
-tests =
- testGroup "Text"
- [ Write.tests
- ]
+++ /dev/null
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE InstanceSigs #-}
--- {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE NoIncoherentInstances #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE OverloadedLists #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE NoUndecidableInstances #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Hcompta.Repr.Text.Write where
-
-import Data.Eq (Eq(..))
-import Data.Function (($), (.))
-import Data.Int (Int)
-import Data.Monoid ((<>))
-import Data.Ord (Ord(..))
-import Data.Text.Buildable (Buildable(..))
-import qualified Data.Text.Lazy as TL
-import qualified Data.Text.Lazy.Builder as TL
-import Prelude (pred, succ)
-import Text.Show (Show(..))
-
-import Hcompta.Expr
-
--- * Type 'Repr_Text_Write'
-
--- | /Tagless-final interpreter/
--- to evaluate an expression to a 'TL.Builder'.
-newtype Repr_Text_Write h
- = Repr_Text_Write
- { unRepr_Text_Write
- :: Precedence -> Var_Depth -- inherited attributes
- -> TL.Builder -- synthetised attributes
- }
-{-
-data Write_Inh
- = Write_Inh
- { Write_Precedence :: Precedence
- , Write_Var_Depth :: Var_Depth
- }
-data Write_Syn
- = Write_Syn
- { Write_Syn_Text :: TL.Builder
- }
--}
-type Var_Depth = Int
-
-repr_text_write :: Repr_Text_Write a -> TL.Builder
-repr_text_write x = unRepr_Text_Write x precedence_Toplevel 0
-instance Show (Repr_Text_Write a) where
- show = TL.unpack . TL.toLazyText . repr_text_write
-
-instance Expr_Lit Repr_Text_Write where
- lit a = Repr_Text_Write $ \_p _v -> build a
-instance Expr_Bool Repr_Text_Write where
- and (Repr_Text_Write x) (Repr_Text_Write y) =
- Repr_Text_Write $ \p v ->
- let p' = precedence_And in
- paren p p' $ x p' v <> " & " <> y p' v
- or (Repr_Text_Write x) (Repr_Text_Write y) =
- Repr_Text_Write $ \p v ->
- let p' = precedence_Or in
- paren p p' $ x p' v <> " | " <> y p' v
- neg (Repr_Text_Write x) =
- Repr_Text_Write $ \p v ->
- let p' = precedence_Neg in
- paren p p' $ "!" <> x (precedence_succ p') v
-instance Expr_Fun Repr_Text_Write where
- app (Repr_Text_Write f) (Repr_Text_Write x) = Repr_Text_Write $ \p v ->
- let p' = precedence_App in
- paren p p' $
- f p' v <> " " <> x p' v
- lazy = repr_text_write_fun "~"
- val = repr_text_write_fun ""
- inline = repr_text_write_fun "!"
- let_lazy = repr_text_write_let "~"
- let_val = repr_text_write_let ""
- let_inline = repr_text_write_let "!"
-
--- ** Instance 'Fun' helpers
-repr_text_write_fun :: TL.Builder -> (Repr_Text_Write a2 -> Repr_Text_Write a1) -> Repr_Text_Write a
-repr_text_write_fun mode e =
- Repr_Text_Write $ \p v ->
- let p' = precedence_Fun in
- let x = "x" <> build v in
- paren p p' $
- "\\" <> mode <> x <> " -> " <>
- unRepr_Text_Write (e (Repr_Text_Write $ \_p _v -> x)) p' (succ v)
-repr_text_write_let
- :: TL.Builder
- -> Repr_Text_Write a1
- -> (Repr_Text_Write a3 -> Repr_Text_Write a2)
- -> Repr_Text_Write a
-repr_text_write_let mode e in_ =
- Repr_Text_Write $ \p v ->
- let p' = precedence_Let in
- let x = "x" <> build v in
- paren p p' $
- "let" <> mode <> " " <> x <> " = " <> unRepr_Text_Write e p (succ v) <> " in " <>
- unRepr_Text_Write (in_ (Repr_Text_Write $ \_p _v -> x)) p (succ v)
-
-instance Expr_If Repr_Text_Write where
- if_
- (Repr_Text_Write cond)
- (Repr_Text_Write ok)
- (Repr_Text_Write ko) =
- Repr_Text_Write $ \p v ->
- let p' = precedence_If in
- paren p p' $
- "if " <> cond p' v <>
- " then " <> ok p' v <>
- " else " <> ko p' v
- when_ (Repr_Text_Write cond) (Repr_Text_Write ok) =
- Repr_Text_Write $ \p v ->
- let p' = precedence_If in
- paren p p' $
- "when " <> cond p' v <>
- " " <> ok p' v
-
--- ** Type 'Precedence'
-
--- TODO: use an Enum?
-newtype Precedence = Precedence Int
- deriving (Eq, Ord, Show)
-precedence_pred :: Precedence -> Precedence
-precedence_pred (Precedence p) = Precedence (pred p)
-precedence_succ :: Precedence -> Precedence
-precedence_succ (Precedence p) = Precedence (succ p)
-paren :: Precedence -> Precedence -> TL.Builder -> TL.Builder
-paren prec prec' x =
- if prec >= prec'
- then "(" <> x <> ")"
- else x
-
-precedence_Toplevel :: Precedence
-precedence_Toplevel = Precedence 0
-precedence_Fun :: Precedence
-precedence_Fun = Precedence 1
-precedence_Let :: Precedence
-precedence_Let = Precedence 2
-precedence_If :: Precedence
-precedence_If = Precedence 3
-precedence_Or :: Precedence
-precedence_Or = Precedence 4
-precedence_And :: Precedence
-precedence_And = Precedence 5
-precedence_App :: Precedence
-precedence_App = Precedence 6
-precedence_Neg :: Precedence
-precedence_Neg = Precedence 7
-precedence_Atomic :: Precedence
-precedence_Atomic = Precedence 8
+++ /dev/null
-{-# LANGUAGE OverloadedStrings #-}
-
-module Repr.Text.Write.Test where
-
-import Data.Function (($))
-import Data.Text.Lazy.Builder as Build
-import qualified Data.Text.Lazy as Text
-import Test.Tasty
-import Test.Tasty.HUnit
-
-import qualified Expr.Fun.Test as Fun
-import qualified Expr.If.Test as If
-import qualified Expr.Bool.Test as Bool
-import Hcompta.Repr
-
-tests :: TestTree
-tests = testGroup "Write" $
- let (==>) expr expected =
- testCase (Text.unpack expected) $
- Build.toLazyText (repr_text_write expr) @?=
- expected
- in
- [ testGroup "Bool"
- [ Bool.e1 ==> "True & False"
- , Bool.e2 ==> "True & False | True & True"
- , Bool.e3 ==> "(True | False) & (True | True)"
- , Bool.e4 ==> "True & !False"
- , Bool.e5 ==> "True & !x"
- , Bool.e6 ==> "(x | y) & !(x & y)"
- , Bool.e7 ==> "((x | y) & !(x & y) | z) & !(((x | y) & !(x & y)) & z)"
- , Bool.e8 ==> "(x | (y | True) & !(y & True)) & !(x & ((y | True) & !(y & True)))"
- ]
- , testGroup "Fun"
- [ Fun.e1 ==> "\\x0 -> (\\x1 -> (x0 | x1) & !(x0 & x1))"
- , Fun.e2 ==> "\\x0 -> (\\x1 -> x0 & !x1 | !x0 & x1)"
- , Fun.e3 ==> "let x0 = True in x0 & x0"
- , Fun.e4 ==> "let x0 = \\x1 -> x1 & x1 in x0 True"
- , Fun.e5 ==> "\\x0 -> (\\x1 -> x0 & x1)"
- , Fun.e6 ==> "(let x0 = True in x0) & False"
- , Fun.e7 ==> "\\x0 -> x0 True & False"
- , Fun.e8 ==> "\\x0 -> x0 (True & False)"
- ]
- , testGroup "If"
- [ If.e1 ==> "if True then False else True"
- , If.e2 ==> "if True & True then False else True"
- ]
- ]
-
+++ /dev/null
-module Hcompta.Repr.Tree
- ( module Hcompta.Repr.Tree.Read
- ) where
-
-import Hcompta.Repr.Tree.Read
+++ /dev/null
-module Hcompta.Repr.Tree.Read where
+++ /dev/null
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE InstanceSigs #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NoMonomorphismRestriction #-}
-{-# LANGUAGE NoPolyKinds #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-
-module Repr.Tree.Read.Test where
-
-import Test.Tasty
-import Test.Tasty.HUnit
-import Control.Monad (Monad(..))
-import Control.Monad.IO.Class (MonadIO(..))
-import Control.Applicative (Applicative(..), Const(..))
-import Data.Bool (Bool(..))
-import Data.Either (Either(..))
-import Data.Eq (Eq(..))
-import Data.Function (($), (.), id)
-import Data.Functor (Functor(..), (<$>))
-import Data.Monoid ((<>))
-import Data.String (String)
-import Data.Int (Int)
-import Data.Text (Text)
-import qualified Data.Text as Text
-import Data.Text.Buildable (Buildable(..))
-import Data.Text.Lazy.Builder as Build
-import Text.Read (Read, reads)
-import Text.Show (Show(..))
-import Prelude (error, print, IO, undefined, succ)
-import GHC.Prim (Constraint)
-import Data.Proxy (Proxy(..))
-
-import Hcompta.Expr.Lit
-import Hcompta.Expr.Bool
-import Hcompta.Expr.Fun
-import Hcompta.Expr.Dup
-import qualified Expr.Dup.Test as Dup
-import Hcompta.Repr
-import Hcompta.Type
-
-tests :: TestTree
-tests = testGroup "Read" $
- {-let (==>) (tree::Tree) expected@(text::Text) =
- fun_lit_bool_from (Proxy::Proxy (Type_Fun_Lit_Bool_End repr)) tree $ \ty repr ->
- case ty of
- Type_Fun_Next (Type_Litkkk)
- case of
- Left err -> testCase (show expected) $ "" @?= "Error: " <> err
- Right (expr_write {-`Dup` expr_meta-}) ->
- testGroup (show expected)
- [ testCase "Text" $ Build.toLazyText (repr_text_write expr_write) @?= text
- -- , testCase "Meta" $ repr_meta expr_meta >>= (@?= meta)
- ] in
- [ Tree "And" [Tree "Bool" [Tree "True"], Tree "Bool" [Tree "False"]]
- ==> "True & False"
- ]-}
- []
-{-
- let (==>) tree expected@(text, meta) =
- case fromTree tree of
- Left err -> testCase (show expected) $ "" @?= "Error: " <> err
- Right (expr_write `Dup` expr_meta) ->
- testGroup (show expected)
- [ testCase "text" $ Build.toLazyText (repr_text_write expr_write) @?= text
- , testCase "meta" $ repr_meta expr_meta >>= (@?= meta)
- ] in
- [ testGroup "Dup"
- [ Dup.e1 ==> ("True & !(True & True)", False)
- -- , Dup.e2 ==> ("", False)
- ]
- ]
--}
-
+++ /dev/null
-module Repr.Tree.Test where
-
-import Test.Tasty
-import qualified Repr.Tree.Read.Test as Read
-
-tests :: TestTree
-tests =
- testGroup "Tree"
- [ Read.tests
- ]
+++ /dev/null
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Test where
-
-import Data.Function (($))
-import System.IO (IO)
-import Test.Tasty
-
-import qualified Repr.Test as Repr
-import qualified Trans.Test as Trans
-
-main :: IO ()
-main =
- defaultMain $
- testGroup "Hcompta"
- [ Repr.tests
- , Trans.tests
- ]
+++ /dev/null
-module Hcompta.Trans.Bool
- ( module Hcompta.Trans.Bool.Const
- ) where
-
-import Hcompta.Trans.Bool.Const
+++ /dev/null
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# OPTIONS_GHC -fno-warn-tabs #-}
-
-module Hcompta.Trans.Bool.Const where
-
-import Data.Bool
-import Data.Function (($))
-import Data.Text.Buildable (Buildable(..))
-import Text.Show (Show)
-
-import Hcompta.Expr.Trans
-import Hcompta.Expr.Lit
-import Hcompta.Expr.Bool
-
--- * Type 'Trans_Bool_Const'
-
--- * Annotation to propagate constants.
-data Trans_Bool_Const repr h
- = Trans_Bool_Const_Unk (repr h)
- | (Buildable h, Show h)
- => Trans_Bool_Const_Lit h
-
-instance Expr_Lit repr => Trans Trans_Bool_Const repr where
- trans_lift = Trans_Bool_Const_Unk
- trans_apply (Trans_Bool_Const_Unk x) = x
- trans_apply (Trans_Bool_Const_Lit x) = lit x
-
-trans_bool_const
- :: (Expr_Bool repr, Expr_Lit repr)
- => Trans_Bool_Const repr h
- -> repr h
-trans_bool_const = trans_apply
-
-instance Expr_Lit repr => Expr_Lit (Trans_Bool_Const repr) where
- lit = Trans_Bool_Const_Lit
-instance Expr_Bool repr => Expr_Bool (Trans_Bool_Const repr) where
- and (Trans_Bool_Const_Lit True) y = y
- and (Trans_Bool_Const_Lit False) _y = Trans_Bool_Const_Lit False
- and x (Trans_Bool_Const_Lit True) = x
- and _x (Trans_Bool_Const_Lit False) = Trans_Bool_Const_Lit False
- and (Trans_Bool_Const_Unk x)
- (Trans_Bool_Const_Unk y)
- = Trans_Bool_Const_Unk $ and x y
-
- or (Trans_Bool_Const_Lit False) y = y
- or (Trans_Bool_Const_Lit True) _y = Trans_Bool_Const_Lit True
- or x (Trans_Bool_Const_Lit False) = x
- or _x (Trans_Bool_Const_Lit True) = Trans_Bool_Const_Lit True
- or (Trans_Bool_Const_Unk x)
- (Trans_Bool_Const_Unk y)
- = Trans_Bool_Const_Unk $ or x y
-
- neg (Trans_Bool_Const_Unk e) = Trans_Bool_Const_Unk $ neg e
- neg (Trans_Bool_Const_Lit x) = Trans_Bool_Const_Lit $ not x
+++ /dev/null
-{-# LANGUAGE OverloadedStrings #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Trans.Bool.Const.Test where
-
-import Data.Function (($))
-import qualified Data.Text.Lazy as Text
-import Data.Text.Lazy.Builder as Build
-import Test.Tasty
-import Test.Tasty.HUnit
-
-import qualified Expr.Bool.Test as Bool
-import qualified Repr.Text.Write.Test ()
-import Hcompta.Repr
-import Hcompta.Trans
-
-tests :: TestTree
-tests = testGroup "Const" $
- let (==>) expr expected =
- testCase (Text.unpack expected) $
- Build.toLazyText (repr_text_write $ trans_bool_const expr) @?=
- expected
- in
- [ Bool.e1 ==> "False"
- , Bool.e2 ==> "True"
- , Bool.e3 ==> "True"
- , Bool.e4 ==> "True"
- , Bool.e5 ==> "!x"
- , Bool.e6 ==> "(x | y) & !(x & y)"
- , Bool.e7 ==> "((x | y) & !(x & y) | z) & !(((x | y) & !(x & y)) & z)"
- , Bool.e8 ==> "(x | !y) & !(x & !y)"
- ]
-
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-module Trans.Bool.Test where
-
-import Test.Tasty
-import qualified Trans.Bool.Const.Test as Const
-
-tests :: TestTree
-tests =
- testGroup "Bool"
- [ Const.tests
- ]
+++ /dev/null
-../HLint.hs
\ No newline at end of file
+++ /dev/null
-module Trans.Test where
-
-import Test.Tasty
-import qualified Trans.Bool.Test as Bool
-
-tests :: TestTree
-tests =
- testGroup "Trans"
- [ Bool.tests
- ]
+++ /dev/null
-import Distribution.Simple
-main = defaultMain
+++ /dev/null
-author: Julien Moutinho <julm+hcompta@autogeree.net>
--- bug-reports: http://bug.autogeree.net/hcompta
-build-type: Simple
-cabal-version: >= 1.8
-category: Finance
--- data-dir: data
--- data-files:
-description: Hcompta command line interface.
-extra-tmp-files:
-extra-source-files:
--- homepage: http://pad.autogeree.net/hcompta
-license: GPL-3
-license-file: COPYING
-maintainer: Julien Moutinho <julm+hcompta@autogeree.net>
-name: hcompta-cli
-stability: experimental
-synopsis: hcompta
-tested-with: GHC==7.10.3
-version: 1.201608
-
-Source-Repository head
- location: git://git.autogeree.net/hcompta
- type: git
-
-Flag dev
- Description: Turn on development settings.
- Default: False
- Manual: True
-
-Flag dump
- Default: False
- Description: Dump some intermediate files.
- Manual: True
-
-Flag library-only
- Description: Build only library.
- Default: False
- Manual: True
-
-Flag prof
- Default: False
- Description: Turn on profiling settings.
- Manual: True
-
-Flag threaded
- Default: True
- Description: Enable threads.
- Manual: True
-
-Library
- extensions: NoImplicitPrelude
- ghc-options: -Wall -fno-warn-tabs
- if flag(dev)
- cpp-options: -DDEVELOPMENT
- ghc-options:
- if flag(dump)
- ghc-options: -ddump-ds -ddump-simpl -ddump-splices -ddump-stg -ddump-to-file
- if flag(prof)
- cpp-options: -DPROFILING
- ghc-options: -fprof-auto
- -- default-language: Haskell2010
- exposed-modules:
- Hcompta.CLI.Args
- Hcompta.CLI.Command
- -- Hcompta.CLI.Command.Balance
- -- Hcompta.CLI.Command.GL
- -- Hcompta.CLI.Command.Journal
- Hcompta.CLI.Command.Journals
- -- Hcompta.CLI.Command.Stats
- -- Hcompta.CLI.Command.Tags
- Hcompta.CLI.Context
- Hcompta.CLI.Env
- Hcompta.CLI.Convert
- Hcompta.CLI.Format
- Hcompta.CLI.Format.JCC
- Hcompta.CLI.Format.Ledger
- Hcompta.CLI.Lang
- Hcompta.CLI.Write
- Hcompta.Expr
- Hcompta.Expr.Bool
- Hcompta.Expr.Dup
- Hcompta.Expr.Eq
- Hcompta.Expr.Fun
- Hcompta.Expr.If
- Hcompta.Expr.Lit
- Hcompta.Expr.Log
- Hcompta.Expr.Maybe
- Hcompta.Expr.Ord
- Hcompta.Expr.Set
- Hcompta.Expr.Trans
- Hcompta.Repr
- Hcompta.Repr.Meta
- Hcompta.Repr.Text
- Hcompta.Repr.Text.Write
- Hcompta.Repr.Tree
- Hcompta.Repr.Tree.Read
- Hcompta.Trans
- Hcompta.Trans.Bool
- Hcompta.Trans.Bool.Const
- Hcompta.Type
- build-depends:
- base >= 4.6 && < 5
- , ansi-terminal >= 0.4 && < 0.7
- , bytestring
- , containers
- , Decimal
- , deepseq
- -- , directory
- , exceptions
- , ghc-prim
- , hcompta-jcc
- , hcompta-ledger
- , hcompta-lib
- -- , HUnit
- , io-memoize >= 1.1
- -- NOTE: needed for System.IO.Memoize.once
- , monad-classes
- , parsec
- , parsec-error-custom
- -- , safe >= 0.2
- , safe-exceptions
- , semigroups
- , strict
- -- , template-haskell
- , text
- , text-format
- , time
- , transformers >= 0.4 && < 0.5
- -- NOTE: needed for Control.Monad.Trans.Except
- , treemap
- , walderleijen-ansi-text
-
-Executable hcompta
- extensions: NoImplicitPrelude
- ghc-options: -Wall -fno-warn-tabs
- if flag(threaded)
- ghc-options: -threaded -rtsopts -with-rtsopts=-N
- if flag(dev)
- cpp-options: -DDEVELOPMENT
- ghc-options:
- if flag(prof)
- cpp-options: -DPROFILING
- ghc-options: -fprof-auto
- if flag(library-only)
- Buildable: False
- main-is: Hcompta/CLI/Main.hs
- hs-source-dirs: .
- build-depends:
- base >= 4.6 && < 5
- , ansi-terminal >= 0.4 && < 0.7
- , bytestring
- , containers >= 0.5 && < 0.6
- -- NOTE: needed for Data.Map.Strict
- , Decimal
- , deepseq
- -- , directory
- , ghc-prim
- , hcompta-jcc
- , hcompta-ledger
- , hcompta-lib
- -- , HUnit
- , io-memoize >= 1.1
- -- NOTE: needed for System.IO.Memoize.once
- , parsec
- , parsec-error-custom
- -- , safe >= 0.2
- , semigroups
- , strict
- -- , template-haskell
- , text
- , time
- , transformers >= 0.4 && < 0.5
- -- NOTE: needed for Control.Monad.Trans.Except
- , treemap
- , walderleijen-ansi-text
-
-
-Test-Suite hcompta-cli-test
- type: exitcode-stdio-1.0
- -- default-language: Haskell2010
- extensions: NoImplicitPrelude
- ghc-options: -Wall -fno-warn-tabs
- -main-is Test
- hs-source-dirs: Hcompta
- main-is: Test.hs
- other-modules:
- Repr.Test
- Repr.Text
- Repr.Text.Write
- Repr.Text.Write.Test
- Repr.Tree
- Repr.Tree.Read
- Repr.Tree.Read.Test
- -- Repr.Meta
- -- Repr.Meta.Test
- Expr.Bool.Test
- Expr.Dup.Test
- Expr.Fun.Test
- Expr.If.Test
- Trans.Bool.Const.Test
- Trans.Bool.Test
- Trans.Test
- if flag(threaded)
- ghc-options: -threaded -rtsopts -with-rtsopts=-N
- if flag(dev)
- cpp-options: -DDEVELOPMENT
- ghc-options:
- if flag(prof)
- cpp-options: -DPROFILING
- ghc-options: -fprof-auto
- build-depends:
- base >= 4.6 && < 5
- , containers >= 0.5 && < 0.6
- , Decimal
- , ghc-prim
- , hcompta-lib
- , hcompta-cli
- , semigroups
- , strict
- , tasty >= 0.11
- , tasty-hunit
- , text
- , text-format
- , transformers >= 0.4 && < 0.5
- , treemap