hledger-lib-0.22/0000755000000000000000000000000012252750510012000 5ustar0000000000000000hledger-lib-0.22/Setup.hs0000644000000000000000000000005612252750510013435 0ustar0000000000000000import Distribution.Simple main = defaultMain hledger-lib-0.22/LICENSE0000644000000000000000000010451312252750510013011 0ustar0000000000000000 GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. 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. Copyright (C) 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 . 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: Copyright (C) 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 . 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 . hledger-lib-0.22/Hledger.hs0000644000000000000000000000101512252750510013703 0ustar0000000000000000module Hledger ( module Hledger.Data ,module Hledger.Query ,module Hledger.Read ,module Hledger.Reports ,module Hledger.Utils ,tests_Hledger ) where import Test.HUnit import Hledger.Data import Hledger.Query import Hledger.Read hiding (samplejournal) import Hledger.Reports import Hledger.Utils tests_Hledger = TestList [ tests_Hledger_Data ,tests_Hledger_Query ,tests_Hledger_Read ,tests_Hledger_Reports ] hledger-lib-0.22/hledger-lib.cabal0000644000000000000000000000733312252750510015150 0ustar0000000000000000name: hledger-lib version: 0.22 stability: beta category: Finance synopsis: Core data types, parsers and utilities for the hledger accounting tool. description: hledger is a library and set of user tools for working with financial data (or anything that can be tracked in a double-entry accounting ledger.) It is a haskell port and friendly fork of John Wiegley's Ledger. hledger provides command-line, curses and web interfaces, and aims to be a reliable, practical tool for daily use. license: GPL license-file: LICENSE author: Simon Michael maintainer: Simon Michael homepage: http://hledger.org bug-reports: http://hledger.org/bugs tested-with: GHC==7.4.2, GHC==7.6.3 cabal-version: >= 1.10 build-type: Simple -- data-dir: data -- data-files: -- extra-tmp-files: extra-source-files: tests/suite.hs -- README -- sample.ledger -- sample.timelog library -- should set patchlevel here as in Makefile cpp-options: -DPATCHLEVEL=0 exposed-modules: Hledger Hledger.Data Hledger.Data.Account Hledger.Data.AccountName Hledger.Data.Amount Hledger.Data.Commodity Hledger.Data.Dates Hledger.Data.FormatStrings Hledger.Data.Journal Hledger.Data.Ledger Hledger.Data.Posting Hledger.Data.TimeLog Hledger.Data.Transaction Hledger.Data.Types Hledger.Query Hledger.Read Hledger.Read.CsvReader Hledger.Read.JournalReader Hledger.Read.TimelogReader Hledger.Reports Hledger.Utils Hledger.Utils.UTF8IOCompat build-depends: base >= 4.3 && < 5 ,bytestring ,cmdargs >= 0.10 && < 0.11 ,containers ,csv ,data-pprint >= 0.2.3 && < 0.3 ,directory ,filepath ,mtl ,old-locale ,old-time ,parsec ,pretty-show ,regex-compat-tdfa == 0.95.* ,regexpr >= 0.5.1 ,safe >= 0.2 ,split >= 0.1 && < 0.3 ,time ,transformers >= 0.2 && < 0.4 ,utf8-string >= 0.3.5 && < 0.4 ,HUnit default-language: Haskell2010 source-repository head type: git location: https://github.com/simonmichael/hledger test-suite tests type: exitcode-stdio-1.0 main-is: tests/suite.hs ghc-options: -Wall build-depends: hledger-lib , base >= 4.3 && < 5 , cmdargs , containers , csv , data-pprint >= 0.2.3 && < 0.3 , directory , filepath , HUnit , mtl , old-locale , old-time , parsec , pretty-show , regex-compat-tdfa , regexpr , safe , split , test-framework , test-framework-hunit , time , transformers default-language: Haskell2010 -- cf http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html -- Additional dependencies: -- required for make test: test-framework, test-framework-hunit -- required for make bench: tabular-0.1 hledger-lib-0.22/Hledger/0000755000000000000000000000000012252750510013352 5ustar0000000000000000hledger-lib-0.22/Hledger/Data.hs0000644000000000000000000000305212252750510014557 0ustar0000000000000000{-| The Hledger.Data library allows parsing and querying of C++ ledger-style journal files. It generally provides a compatible subset of C++ ledger's functionality. This package re-exports all the Hledger.Data.* modules (except UTF8, which requires an explicit import.) -} module Hledger.Data ( module Hledger.Data.Account, module Hledger.Data.AccountName, module Hledger.Data.Amount, module Hledger.Data.Commodity, module Hledger.Data.Dates, module Hledger.Data.Journal, module Hledger.Data.Ledger, module Hledger.Data.Posting, module Hledger.Data.TimeLog, module Hledger.Data.Transaction, module Hledger.Data.Types, tests_Hledger_Data ) where import Test.HUnit import Hledger.Data.Account import Hledger.Data.AccountName import Hledger.Data.Amount import Hledger.Data.Commodity import Hledger.Data.Dates import Hledger.Data.Journal import Hledger.Data.Ledger import Hledger.Data.Posting import Hledger.Data.TimeLog import Hledger.Data.Transaction import Hledger.Data.Types tests_Hledger_Data = TestList [ tests_Hledger_Data_Account ,tests_Hledger_Data_AccountName ,tests_Hledger_Data_Amount ,tests_Hledger_Data_Commodity ,tests_Hledger_Data_Dates ,tests_Hledger_Data_Journal ,tests_Hledger_Data_Ledger ,tests_Hledger_Data_Posting ,tests_Hledger_Data_TimeLog ,tests_Hledger_Data_Transaction -- ,tests_Hledger_Data_Types ] hledger-lib-0.22/Hledger/Read.hs0000644000000000000000000002110112252750510014554 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-| This is the entry point to hledger's reading system, which can read Journals from various data formats. Use this module if you want to parse journal data or read journal files. Generally it should not be necessary to import modules below this one. -} module Hledger.Read ( -- * Journal reading API defaultJournalPath, defaultJournal, readJournal, readJournal', readJournalFile, requireJournalFileExists, ensureJournalFileExists, -- * Parsers used elsewhere accountname, amountp, amountp', mamountp', code, -- * Tests samplejournal, tests_Hledger_Read, ) where import qualified Control.Exception as C import Control.Monad.Error import Data.List import Data.Maybe import System.Directory (doesFileExist, getHomeDirectory) import System.Environment (getEnv) import System.Exit (exitFailure) import System.FilePath (()) import System.IO (IOMode(..), withFile, stdin, stderr, hSetNewlineMode, universalNewlineMode) import Test.HUnit import Text.Printf import Hledger.Data.Dates (getCurrentDay) import Hledger.Data.Types import Hledger.Data.Journal (nullctx) import Hledger.Read.JournalReader as JournalReader import Hledger.Read.TimelogReader as TimelogReader import Hledger.Read.CsvReader as CsvReader import Hledger.Utils import Prelude hiding (getContents, writeFile) import Hledger.Utils.UTF8IOCompat (getContents, hGetContents, writeFile) journalEnvVar = "LEDGER_FILE" journalEnvVar2 = "LEDGER" journalDefaultFilename = ".hledger.journal" -- The available data file readers, each one handling a particular data -- format. The first is also used as the default for unknown formats. readers :: [Reader] readers = [ JournalReader.reader ,TimelogReader.reader ,CsvReader.reader ] -- | All the data formats we can read. -- formats = map rFormat readers -- | Get the default journal file path specified by the environment. -- Like ledger, we look first for the LEDGER_FILE environment -- variable, and if that does not exist, for the legacy LEDGER -- environment variable. If neither is set, or the value is blank, -- return the hard-coded default, which is @.hledger.journal@ in the -- users's home directory (or in the current directory, if we cannot -- determine a home directory). defaultJournalPath :: IO String defaultJournalPath = do s <- envJournalPath if null s then defaultJournalPath else return s where envJournalPath = getEnv journalEnvVar `C.catch` (\(_::C.IOException) -> getEnv journalEnvVar2 `C.catch` (\(_::C.IOException) -> return "")) defaultJournalPath = do home <- getHomeDirectory `C.catch` (\(_::C.IOException) -> return "") return $ home journalDefaultFilename -- | Read the default journal file specified by the environment, or raise an error. defaultJournal :: IO Journal defaultJournal = defaultJournalPath >>= readJournalFile Nothing Nothing >>= either error' return -- | Read a journal from the given string, trying all known formats, or simply throw an error. readJournal' :: String -> IO Journal readJournal' s = readJournal Nothing Nothing Nothing s >>= either error' return tests_readJournal' = [ "readJournal' parses sample journal" ~: do _ <- samplejournal assertBool "" True ] -- | Read a journal from this string, trying whatever readers seem appropriate: -- -- - if a format is specified, try that reader only -- -- - or if one or more readers recognises the file path and data, try those -- -- - otherwise, try them all. -- -- A CSV conversion rules file may also be specified for use by the CSV reader. readJournal :: Maybe Format -> Maybe FilePath -> Maybe FilePath -> String -> IO (Either String Journal) readJournal format rulesfile path s = -- trace (show (format, rulesfile, path)) $ tryReaders $ readersFor (format, path, s) where -- try each reader in turn, returning the error of the first if all fail tryReaders :: [Reader] -> IO (Either String Journal) tryReaders = firstSuccessOrBestError [] where firstSuccessOrBestError :: [String] -> [Reader] -> IO (Either String Journal) firstSuccessOrBestError [] [] = return $ Left "no readers found" firstSuccessOrBestError errs (r:rs) = do -- printf "trying %s reader\n" (rFormat r) result <- (runErrorT . (rParser r) rulesfile path') s case result of Right j -> return $ Right j -- success! Left e -> firstSuccessOrBestError (errs++[e]) rs -- keep trying firstSuccessOrBestError (e:_) [] = return $ Left e -- none left, return first error path' = fromMaybe "(string)" path -- | Which readers are worth trying for this (possibly unspecified) format, filepath, and data ? readersFor :: (Maybe Format, Maybe FilePath, String) -> [Reader] readersFor (format,path,s) = case format of Just f -> case readerForFormat f of Just r -> [r] Nothing -> [] Nothing -> case path of Nothing -> readers Just "-" -> readers Just p -> case readersForPathAndData (p,s) of [] -> readers rs -> rs -- | Find the (first) reader which can handle the given format, if any. readerForFormat :: Format -> Maybe Reader readerForFormat s | null rs = Nothing | otherwise = Just $ head rs where rs = filter ((s==).rFormat) readers :: [Reader] -- | Find the readers which think they can handle the given file path and data, if any. readersForPathAndData :: (FilePath,String) -> [Reader] readersForPathAndData (f,s) = filter (\r -> (rDetector r) f s) readers -- | Read a Journal from this file (or stdin if the filename is -) or give -- an error message, using the specified data format or trying all known -- formats. A CSV conversion rules file may be specified for better -- conversion of that format. readJournalFile :: Maybe Format -> Maybe FilePath -> FilePath -> IO (Either String Journal) readJournalFile format rulesfile "-" = do hSetNewlineMode stdin universalNewlineMode getContents >>= readJournal format rulesfile (Just "(stdin)") readJournalFile format rulesfile f = do requireJournalFileExists f withFile f ReadMode $ \h -> do hSetNewlineMode h universalNewlineMode hGetContents h >>= readJournal format rulesfile (Just f) -- | If the specified journal file does not exist, give a helpful error and quit. requireJournalFileExists :: FilePath -> IO () requireJournalFileExists f = do exists <- doesFileExist f when (not exists) $ do hPrintf stderr "The hledger journal file \"%s\" was not found.\n" f hPrintf stderr "Please create it first, eg with hledger add or a text editor.\n" hPrintf stderr "Or, specify an existing journal file with -f or LEDGER_FILE.\n" exitFailure -- | Ensure there is a journal file at the given path, creating an empty one if needed. ensureJournalFileExists :: FilePath -> IO () ensureJournalFileExists f = do exists <- doesFileExist f when (not exists) $ do hPrintf stderr "Creating hledger journal file \"%s\".\n" f -- note Hledger.Utils.UTF8.* do no line ending conversion on windows, -- we currently require unix line endings on all platforms. newJournalContent >>= writeFile f -- | Give the content for a new auto-created journal file. newJournalContent :: IO String newJournalContent = do d <- getCurrentDay return $ printf "; journal created %s by hledger\n" (show d) -- tests samplejournal = readJournal' $ unlines ["2008/01/01 income" ," assets:bank:checking $1" ," income:salary" ,"" ,"2008/06/01 gift" ," assets:bank:checking $1" ," income:gifts" ,"" ,"2008/06/02 save" ," assets:bank:saving $1" ," assets:bank:checking" ,"" ,"2008/06/03 * eat & shop" ," expenses:food $1" ," expenses:supplies $1" ," assets:cash" ,"" ,"2008/12/31 * pay off" ," liabilities:debts $1" ," assets:bank:checking" ] tests_Hledger_Read = TestList $ tests_readJournal' ++ [ -- tests_Hledger_Read_JournalReader, tests_Hledger_Read_TimelogReader, tests_Hledger_Read_CsvReader, "journal" ~: do assertBool "journal should parse an empty file" (isRight $ parseWithCtx nullctx JournalReader.journal "") jE <- readJournal Nothing Nothing Nothing "" -- don't know how to get it from journal either error' (assertBool "journal parsing an empty file should give an empty journal" . null . jtxns) jE ] hledger-lib-0.22/Hledger/Query.hs0000644000000000000000000006747612252750510015037 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-| A general query system for matching things (accounts, postings, transactions..) by various criteria, and a parser for query expressions. -} module Hledger.Query ( -- * Query and QueryOpt Query(..), QueryOpt(..), -- * parsing parseQuery, simplifyQuery, filterQuery, -- * accessors queryIsNull, queryIsDepth, queryIsDate, queryIsStartDateOnly, queryStartDate, queryDateSpan, queryDepth, queryEmpty, inAccount, inAccountQuery, -- * matching matchesAccount, matchesPosting, matchesTransaction, -- * tests tests_Hledger_Query ) where import Data.Data import Data.Either import Data.List import Data.Maybe import Data.Time.Calendar import Safe (readDef, headDef, headMay) import Test.HUnit import Text.ParserCombinators.Parsec import Hledger.Utils import Hledger.Data.Types import Hledger.Data.AccountName import Hledger.Data.Amount (amount, usd) import Hledger.Data.Dates import Hledger.Data.Posting import Hledger.Data.Transaction -- | A query is a composition of search criteria, which can be used to -- match postings, transactions, accounts and more. data Query = Any -- ^ always match | None -- ^ never match | Not Query -- ^ negate this match | Or [Query] -- ^ match if any of these match | And [Query] -- ^ match if all of these match | Code String -- ^ match if code matches this regexp | Desc String -- ^ match if description matches this regexp | Acct String -- ^ match postings whose account matches this regexp | Date DateSpan -- ^ match if primary date in this date span | Date2 DateSpan -- ^ match if secondary date in this date span | Status Bool -- ^ match if cleared status has this value | Real Bool -- ^ match if "realness" (involves a real non-virtual account ?) has this value | Amt Ordering Quantity -- ^ match if the amount's numeric quantity is less than/greater than/equal to some value | Sym String -- ^ match if the entire commodity symbol is matched by this regexp | Empty Bool -- ^ if true, show zero-amount postings/accounts which are usually not shown -- more of a query option than a query criteria ? | Depth Int -- ^ match if account depth is less than or equal to this value | Tag String (Maybe String) -- ^ match if a tag with this exact name, and with value -- matching the regexp if provided, exists deriving (Eq,Data,Typeable) -- custom Show implementation to show strings more accurately, eg for debugging regexps instance Show Query where show Any = "Any" show None = "None" show (Not q) = "Not (" ++ show q ++ ")" show (Or qs) = "Or (" ++ show qs ++ ")" show (And qs) = "And (" ++ show qs ++ ")" show (Code r) = "Code " ++ show r show (Desc r) = "Desc " ++ show r show (Acct r) = "Acct " ++ show r show (Date ds) = "Date (" ++ show ds ++ ")" show (Date2 ds) = "Date2 (" ++ show ds ++ ")" show (Status b) = "Status " ++ show b show (Real b) = "Real " ++ show b show (Amt ord qty) = "Amt " ++ show ord ++ " " ++ show qty show (Sym r) = "Sym " ++ show r show (Empty b) = "Empty " ++ show b show (Depth n) = "Depth " ++ show n show (Tag s ms) = "Tag " ++ show s ++ " (" ++ show ms ++ ")" -- | A query option changes a query's/report's behaviour and output in some way. data QueryOpt = QueryOptInAcctOnly AccountName -- ^ show an account register focussed on this account | QueryOptInAcct AccountName -- ^ as above but include sub-accounts in the account register -- | QueryOptCostBasis -- ^ show amounts converted to cost where possible -- | QueryOptDate2 -- ^ show secondary dates instead of primary dates deriving (Show, Eq, Data, Typeable) -- parsing -- -- | A query restricting the account(s) to be shown in the sidebar, if any. -- -- Just looks at the first query option. -- showAccountMatcher :: [QueryOpt] -> Maybe Query -- showAccountMatcher (QueryOptInAcctSubsOnly a:_) = Just $ Acct True $ accountNameToAccountRegex a -- showAccountMatcher _ = Nothing -- | Convert a query expression containing zero or more space-separated -- terms to a query and zero or more query options. A query term is either: -- -- 1. a search pattern, which matches on one or more fields, eg: -- -- acct:REGEXP - match the account name with a regular expression -- desc:REGEXP - match the transaction description -- date:PERIODEXP - match the date with a period expression -- -- The prefix indicates the field to match, or if there is no prefix -- account name is assumed. -- -- 2. a query option, which modifies the reporting behaviour in some -- way. There is currently one of these, which may appear only once: -- -- inacct:FULLACCTNAME -- -- The usual shell quoting rules are assumed. When a pattern contains -- whitespace, it (or the whole term including prefix) should be enclosed -- in single or double quotes. -- -- Period expressions may contain relative dates, so a reference date is -- required to fully parse these. -- -- Multiple terms are combined as follows: -- 1. multiple account patterns are OR'd together -- 2. multiple description patterns are OR'd together -- 3. then all terms are AND'd together parseQuery :: Day -> String -> (Query,[QueryOpt]) parseQuery d s = (q, opts) where terms = words'' prefixes s (pats, opts) = partitionEithers $ map (parseQueryTerm d) terms (descpats, pats') = partition queryIsDesc pats (acctpats, otherpats) = partition queryIsAcct pats' q = simplifyQuery $ And $ [Or acctpats, Or descpats] ++ otherpats tests_parseQuery = [ "parseQuery" ~: do let d = nulldate -- parsedate "2011/1/1" parseQuery d "acct:'expenses:autres d\233penses' desc:b" `is` (And [Acct "expenses:autres d\233penses", Desc "b"], []) parseQuery d "inacct:a desc:\"b b\"" `is` (Desc "b b", [QueryOptInAcct "a"]) parseQuery d "inacct:a inacct:b" `is` (Any, [QueryOptInAcct "a", QueryOptInAcct "b"]) parseQuery d "desc:'x x'" `is` (Desc "x x", []) parseQuery d "'a a' 'b" `is` (Or [Acct "a a",Acct "'b"], []) parseQuery d "\"" `is` (Acct "\"", []) ] -- XXX -- | Quote-and-prefix-aware version of words - don't split on spaces which -- are inside quotes, including quotes which may have one of the specified -- prefixes in front, and maybe an additional not: prefix in front of that. words'' :: [String] -> String -> [String] words'' prefixes = fromparse . parsewith maybeprefixedquotedphrases -- XXX where maybeprefixedquotedphrases = choice' [prefixedQuotedPattern, quotedPattern, pattern] `sepBy` many1 spacenonewline prefixedQuotedPattern = do not' <- fromMaybe "" `fmap` (optionMaybe $ string "not:") let allowednexts | null not' = prefixes | otherwise = prefixes ++ [""] next <- choice' $ map string allowednexts let prefix = not' ++ next p <- quotedPattern return $ prefix ++ stripquotes p quotedPattern = do p <- between (oneOf "'\"") (oneOf "'\"") $ many $ noneOf "'\"" return $ stripquotes p pattern = many (noneOf " \n\r") tests_words'' = [ "words''" ~: do assertEqual "1" ["a","b"] (words'' [] "a b") assertEqual "2" ["a b"] (words'' [] "'a b'") assertEqual "3" ["not:a","b"] (words'' [] "not:a b") assertEqual "4" ["not:a b"] (words'' [] "not:'a b'") assertEqual "5" ["not:a b"] (words'' [] "'not:a b'") assertEqual "6" ["not:desc:a b"] (words'' ["desc:"] "not:desc:'a b'") let s `gives` r = assertEqual "" r (words'' prefixes s) "\"acct:expenses:autres d\233penses\"" `gives` ["acct:expenses:autres d\233penses"] "\"" `gives` ["\""] ] -- XXX -- keep synced with patterns below, excluding "not" prefixes = map (++":") [ "inacctonly" ,"inacct" ,"amt" ,"code" ,"desc" ,"acct" ,"date" ,"edate" ,"status" ,"sym" ,"real" ,"empty" ,"depth" ,"tag" ] defaultprefix = "acct" -- -- | Parse the query string as a boolean tree of match patterns. -- parseQueryTerm :: String -> Query -- parseQueryTerm s = either (const (Any)) id $ runParser query () "" $ lexmatcher s -- lexmatcher :: String -> [String] -- lexmatcher s = words' s -- query :: GenParser String () Query -- query = undefined -- | Parse a single query term as either a query or a query option. parseQueryTerm :: Day -> String -> Either Query QueryOpt parseQueryTerm _ ('i':'n':'a':'c':'c':'t':'o':'n':'l':'y':':':s) = Right $ QueryOptInAcctOnly s parseQueryTerm _ ('i':'n':'a':'c':'c':'t':':':s) = Right $ QueryOptInAcct s parseQueryTerm d ('n':'o':'t':':':s) = case parseQueryTerm d s of Left m -> Left $ Not m Right _ -> Left Any -- not:somequeryoption will be ignored parseQueryTerm _ ('c':'o':'d':'e':':':s) = Left $ Code s parseQueryTerm _ ('d':'e':'s':'c':':':s) = Left $ Desc s parseQueryTerm _ ('a':'c':'c':'t':':':s) = Left $ Acct s parseQueryTerm d ('d':'a':'t':'e':':':s) = case parsePeriodExpr d s of Left _ -> Left None -- XXX should warn Right (_,span) -> Left $ Date span parseQueryTerm d ('e':'d':'a':'t':'e':':':s) = case parsePeriodExpr d s of Left _ -> Left None -- XXX should warn Right (_,span) -> Left $ Date2 span parseQueryTerm _ ('s':'t':'a':'t':'u':'s':':':s) = Left $ Status $ parseStatus s parseQueryTerm _ ('r':'e':'a':'l':':':s) = Left $ Real $ parseBool s parseQueryTerm _ ('a':'m':'t':':':s) = Left $ Amt op q where (op, q) = parseAmountQueryTerm s parseQueryTerm _ ('e':'m':'p':'t':'y':':':s) = Left $ Empty $ parseBool s parseQueryTerm _ ('d':'e':'p':'t':'h':':':s) = Left $ Depth $ readDef 0 s parseQueryTerm _ ('s':'y':'m':':':s) = Left $ Sym s parseQueryTerm _ ('t':'a':'g':':':s) = Left $ Tag n v where (n,v) = parseTag s parseQueryTerm _ "" = Left $ Any parseQueryTerm d s = parseQueryTerm d $ defaultprefix++":"++s tests_parseQueryTerm = [ "parseQueryTerm" ~: do let s `gives` r = parseQueryTerm nulldate s `is` r "a" `gives` (Left $ Acct "a") "acct:expenses:autres d\233penses" `gives` (Left $ Acct "expenses:autres d\233penses") "not:desc:a b" `gives` (Left $ Not $ Desc "a b") "status:1" `gives` (Left $ Status True) "status:0" `gives` (Left $ Status False) "status:" `gives` (Left $ Status False) "real:1" `gives` (Left $ Real True) "date:2008" `gives` (Left $ Date $ DateSpan (Just $ parsedate "2008/01/01") (Just $ parsedate "2009/01/01")) "date:from 2012/5/17" `gives` (Left $ Date $ DateSpan (Just $ parsedate "2012/05/17") Nothing) "inacct:a" `gives` (Right $ QueryOptInAcct "a") "tag:a" `gives` (Left $ Tag "a" Nothing) "tag:a=some value" `gives` (Left $ Tag "a" (Just "some value")) -- "amt:<0" `gives` (Left $ Amt LT 0) -- "amt:=.23" `gives` (Left $ Amt EQ 0.23) -- "amt:>10000.10" `gives` (Left $ Amt GT 10000.1) ] -- can fail parseAmountQueryTerm :: String -> (Ordering, Quantity) parseAmountQueryTerm s = case s of "" -> err '<':s' -> (LT, readDef err s') '=':s' -> (EQ, readDef err s') '>':s' -> (GT, readDef err s') s' -> (EQ, readDef err s') where err = error' $ "could not parse as '=', '<', or '>' (optional) followed by a numeric quantity: " ++ s tests_parseAmountQueryTerm = [ "parseAmountQueryTerm" ~: do let s `gives` r = parseAmountQueryTerm s `is` r "<0" `gives` (LT,0) "=0.23" `gives` (EQ,0.23) "0.23" `gives` (EQ,0.23) ">10000.10" `gives` (GT,10000.1) ] parseTag :: String -> (String, Maybe String) parseTag s | '=' `elem` s = (n, Just $ tail v) | otherwise = (s, Nothing) where (n,v) = break (=='=') s -- | Parse the boolean value part of a "status:" query, allowing "*" as -- another way to spell True, similar to the journal file format. parseStatus :: String -> Bool parseStatus s = s `elem` (truestrings ++ ["*"]) -- | Parse the boolean value part of a "status:" query. A true value can -- be spelled as "1", "t" or "true". parseBool :: String -> Bool parseBool s = s `elem` truestrings truestrings :: [String] truestrings = ["1","t","true"] simplifyQuery :: Query -> Query simplifyQuery q = let q' = simplify q in if q' == q then q else simplifyQuery q' where simplify (And []) = Any simplify (And [q]) = simplify q simplify (And qs) | same qs = simplify $ head qs | any (==None) qs = None | all queryIsDate qs = Date $ spansIntersect $ mapMaybe queryTermDateSpan qs | otherwise = And $ concat $ [map simplify dateqs, map simplify otherqs] where (dateqs, otherqs) = partition queryIsDate $ filter (/=Any) qs simplify (Or []) = Any simplify (Or [q]) = simplifyQuery q simplify (Or qs) | same qs = simplify $ head qs | any (==Any) qs = Any -- all queryIsDate qs = Date $ spansUnion $ mapMaybe queryTermDateSpan qs ? | otherwise = Or $ map simplify $ filter (/=None) qs simplify (Date (DateSpan Nothing Nothing)) = Any simplify q = q tests_simplifyQuery = [ "simplifyQuery" ~: do let q `gives` r = assertEqual "" r (simplifyQuery q) Or [Acct "a"] `gives` Acct "a" Or [Any,None] `gives` Any And [Any,None] `gives` None And [Any,Any] `gives` Any And [Acct "b",Any] `gives` Acct "b" And [Any,And [Date (DateSpan Nothing Nothing)]] `gives` Any And [Date (DateSpan Nothing (Just $ parsedate "2013-01-01")), Date (DateSpan (Just $ parsedate "2012-01-01") Nothing)] `gives` Date (DateSpan (Just $ parsedate "2012-01-01") (Just $ parsedate "2013-01-01")) And [Or [],Or [Desc "b b"]] `gives` Desc "b b" ] same [] = True same (a:as) = all (a==) as -- | Remove query terms (or whole sub-expressions) not matching the given -- predicate from this query. XXX Semantics not yet clear. filterQuery :: (Query -> Bool) -> Query -> Query filterQuery p = simplifyQuery . filterQuery' p filterQuery' :: (Query -> Bool) -> Query -> Query filterQuery' p (And qs) = And $ map (filterQuery p) qs filterQuery' p (Or qs) = Or $ map (filterQuery p) qs -- filterQuery' p (Not q) = Not $ filterQuery p q filterQuery' p q = if p q then q else Any tests_filterQuery = [ "filterQuery" ~: do let (q,p) `gives` r = assertEqual "" r (filterQuery p q) (Any, queryIsDepth) `gives` Any (Depth 1, queryIsDepth) `gives` Depth 1 (And [And [Status True,Depth 1]], not . queryIsDepth) `gives` Status True -- (And [Date nulldatespan, Not (Or [Any, Depth 1])], queryIsDepth) `gives` And [Not (Or [Depth 1])] ] -- * accessors -- | Does this query match everything ? queryIsNull :: Query -> Bool queryIsNull Any = True queryIsNull (And []) = True queryIsNull (Not (Or [])) = True queryIsNull _ = False queryIsDepth :: Query -> Bool queryIsDepth (Depth _) = True queryIsDepth _ = False queryIsDate :: Query -> Bool queryIsDate (Date _) = True queryIsDate _ = False queryIsDesc :: Query -> Bool queryIsDesc (Desc _) = True queryIsDesc _ = False queryIsAcct :: Query -> Bool queryIsAcct (Acct _) = True queryIsAcct _ = False -- | Does this query specify a start date and nothing else (that would -- filter postings prior to the date) ? -- When the flag is true, look for a starting secondary date instead. queryIsStartDateOnly :: Bool -> Query -> Bool queryIsStartDateOnly _ Any = False queryIsStartDateOnly _ None = False queryIsStartDateOnly secondary (Or ms) = and $ map (queryIsStartDateOnly secondary) ms queryIsStartDateOnly secondary (And ms) = and $ map (queryIsStartDateOnly secondary) ms queryIsStartDateOnly False (Date (DateSpan (Just _) _)) = True queryIsStartDateOnly True (Date2 (DateSpan (Just _) _)) = True queryIsStartDateOnly _ _ = False -- | What start date (or secondary date) does this query specify, if any ? -- For OR expressions, use the earliest of the dates. NOT is ignored. queryStartDate :: Bool -> Query -> Maybe Day queryStartDate secondary (Or ms) = earliestMaybeDate $ map (queryStartDate secondary) ms queryStartDate secondary (And ms) = latestMaybeDate $ map (queryStartDate secondary) ms queryStartDate False (Date (DateSpan (Just d) _)) = Just d queryStartDate True (Date2 (DateSpan (Just d) _)) = Just d queryStartDate _ _ = Nothing queryTermDateSpan (Date span) = Just span queryTermDateSpan _ = Nothing -- | What date span (or secondary date span) does this query specify ? -- For OR expressions, use the widest possible span. NOT is ignored. queryDateSpan :: Bool -> Query -> DateSpan queryDateSpan secondary q = spansUnion $ queryDateSpans secondary q -- | Extract all date (or secondary date) spans specified in this query. -- NOT is ignored. queryDateSpans :: Bool -> Query -> [DateSpan] queryDateSpans secondary (Or qs) = concatMap (queryDateSpans secondary) qs queryDateSpans secondary (And qs) = concatMap (queryDateSpans secondary) qs queryDateSpans False (Date span) = [span] queryDateSpans True (Date2 span) = [span] queryDateSpans _ _ = [] -- | What is the earliest of these dates, where Nothing is earliest ? earliestMaybeDate :: [Maybe Day] -> Maybe Day earliestMaybeDate = headDef Nothing . sortBy compareMaybeDates -- | What is the latest of these dates, where Nothing is earliest ? latestMaybeDate :: [Maybe Day] -> Maybe Day latestMaybeDate = headDef Nothing . sortBy (flip compareMaybeDates) -- | Compare two maybe dates, Nothing is earliest. compareMaybeDates :: Maybe Day -> Maybe Day -> Ordering compareMaybeDates Nothing Nothing = EQ compareMaybeDates Nothing (Just _) = LT compareMaybeDates (Just _) Nothing = GT compareMaybeDates (Just a) (Just b) = compare a b -- | The depth limit this query specifies, or a large number if none. queryDepth :: Query -> Int queryDepth q = case queryDepth' q of [] -> 99999 ds -> minimum ds where queryDepth' (Depth d) = [d] queryDepth' (Or qs) = concatMap queryDepth' qs queryDepth' (And qs) = concatMap queryDepth' qs queryDepth' _ = [] -- | The empty (zero amount) status specified by this query, defaulting to false. queryEmpty :: Query -> Bool queryEmpty = headDef False . queryEmpty' where queryEmpty' (Empty v) = [v] queryEmpty' (Or qs) = concatMap queryEmpty' qs queryEmpty' (And qs) = concatMap queryEmpty' qs queryEmpty' _ = [] -- -- | The "include empty" option specified by this query, defaulting to false. -- emptyQueryOpt :: [QueryOpt] -> Bool -- emptyQueryOpt = headDef False . emptyQueryOpt' -- where -- emptyQueryOpt' [] = False -- emptyQueryOpt' (QueryOptEmpty v:_) = v -- emptyQueryOpt' (_:vs) = emptyQueryOpt' vs -- | The account we are currently focussed on, if any, and whether subaccounts are included. -- Just looks at the first query option. inAccount :: [QueryOpt] -> Maybe (AccountName,Bool) inAccount [] = Nothing inAccount (QueryOptInAcctOnly a:_) = Just (a,False) inAccount (QueryOptInAcct a:_) = Just (a,True) -- | A query for the account(s) we are currently focussed on, if any. -- Just looks at the first query option. inAccountQuery :: [QueryOpt] -> Maybe Query inAccountQuery [] = Nothing inAccountQuery (QueryOptInAcctOnly a:_) = Just $ Acct $ accountNameToAccountOnlyRegex a inAccountQuery (QueryOptInAcct a:_) = Just $ Acct $ accountNameToAccountRegex a -- -- | Convert a query to its inverse. -- negateQuery :: Query -> Query -- negateQuery = Not -- matching -- | Does the match expression match this account ? -- A matching in: clause is also considered a match. matchesAccount :: Query -> AccountName -> Bool matchesAccount (None) _ = False matchesAccount (Not m) a = not $ matchesAccount m a matchesAccount (Or ms) a = any (`matchesAccount` a) ms matchesAccount (And ms) a = all (`matchesAccount` a) ms matchesAccount (Acct r) a = regexMatchesCI r a matchesAccount (Depth d) a = accountNameLevel a <= d matchesAccount (Tag _ _) _ = False matchesAccount _ _ = True tests_matchesAccount = [ "matchesAccount" ~: do assertBool "positive acct match" $ matchesAccount (Acct "b:c") "a:bb:c:d" -- assertBool "acct should match at beginning" $ not $ matchesAccount (Acct True "a:b") "c:a:b" let q `matches` a = assertBool "" $ q `matchesAccount` a Depth 2 `matches` "a:b" assertBool "" $ Depth 2 `matchesAccount` "a" assertBool "" $ Depth 2 `matchesAccount` "a:b" assertBool "" $ not $ Depth 2 `matchesAccount` "a:b:c" assertBool "" $ Date nulldatespan `matchesAccount` "a" assertBool "" $ Date2 nulldatespan `matchesAccount` "a" assertBool "" $ not $ (Tag "a" Nothing) `matchesAccount` "a" ] -- | Does the match expression match this posting ? matchesPosting :: Query -> Posting -> Bool matchesPosting (Not q) p = not $ q `matchesPosting` p matchesPosting (Any) _ = True matchesPosting (None) _ = False matchesPosting (Or qs) p = any (`matchesPosting` p) qs matchesPosting (And qs) p = all (`matchesPosting` p) qs matchesPosting (Code r) p = regexMatchesCI r $ maybe "" tcode $ ptransaction p matchesPosting (Desc r) p = regexMatchesCI r $ maybe "" tdescription $ ptransaction p matchesPosting (Acct r) p = regexMatchesCI r $ paccount p matchesPosting (Date span) p = span `spanContainsDate` postingDate p matchesPosting (Date2 span) p = span `spanContainsDate` postingDate2 p matchesPosting (Status v) p = v == postingCleared p matchesPosting (Real v) p = v == isReal p matchesPosting (Depth d) Posting{paccount=a} = Depth d `matchesAccount` a matchesPosting (Amt op n) Posting{pamount=a} = compareMixedAmount op n a -- matchesPosting (Empty v) Posting{pamount=a} = v == isZeroMixedAmount a -- matchesPosting (Empty False) Posting{pamount=a} = True -- matchesPosting (Empty True) Posting{pamount=a} = isZeroMixedAmount a matchesPosting (Empty _) _ = True matchesPosting (Sym r) Posting{pamount=Mixed as} = any (regexMatchesCI $ "^" ++ r ++ "$") $ map acommodity as matchesPosting (Tag n Nothing) p = isJust $ lookupTagByName n $ postingAllTags p matchesPosting (Tag n (Just v)) p = isJust $ lookupTagByNameAndValue (n,v) $ postingAllTags p -- matchesPosting _ _ = False -- | Is this simple mixed amount's quantity less than, equal to, or greater than this number ? -- For complext mixed amounts (with multiple commodities), this is always true. compareMixedAmount :: Ordering -> Quantity -> MixedAmount -> Bool compareMixedAmount op q (Mixed []) = compareMixedAmount op q (Mixed [amount]) -- compareMixedAmount op q (Mixed [a]) = strace (compare (strace $ aquantity a) (strace q)) == op compareMixedAmount op q (Mixed [a]) = compare (aquantity a) q == op compareMixedAmount _ _ _ = True tests_matchesPosting = [ "matchesPosting" ~: do -- matching posting status.. assertBool "positive match on true posting status" $ (Status True) `matchesPosting` nullposting{pstatus=True} assertBool "negative match on true posting status" $ not $ (Not $ Status True) `matchesPosting` nullposting{pstatus=True} assertBool "positive match on false posting status" $ (Status False) `matchesPosting` nullposting{pstatus=False} assertBool "negative match on false posting status" $ not $ (Not $ Status False) `matchesPosting` nullposting{pstatus=False} assertBool "positive match on true posting status acquired from transaction" $ (Status True) `matchesPosting` nullposting{pstatus=False,ptransaction=Just nulltransaction{tstatus=True}} assertBool "real:1 on real posting" $ (Real True) `matchesPosting` nullposting{ptype=RegularPosting} assertBool "real:1 on virtual posting fails" $ not $ (Real True) `matchesPosting` nullposting{ptype=VirtualPosting} assertBool "real:1 on balanced virtual posting fails" $ not $ (Real True) `matchesPosting` nullposting{ptype=BalancedVirtualPosting} assertBool "a" $ (Acct "'b") `matchesPosting` nullposting{paccount="'b"} assertBool "b" $ not $ (Tag "a" (Just "r$")) `matchesPosting` nullposting assertBool "c" $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","")]} assertBool "d" $ (Tag "foo" Nothing) `matchesPosting` nullposting{ptags=[("foo","baz")]} assertBool "e" $ (Tag "foo" (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]} assertBool "f" $ not $ (Tag "foo" (Just "a$")) `matchesPosting` nullposting{ptags=[("foo","bar")]} assertBool "g" $ not $ (Tag " foo " (Just "a")) `matchesPosting` nullposting{ptags=[("foo","bar")]} assertBool "h" $ not $ (Tag "foo foo" (Just " ar ba ")) `matchesPosting` nullposting{ptags=[("foo foo","bar bar")]} -- a tag match on a posting also sees inherited tags assertBool "i" $ (Tag "txntag" Nothing) `matchesPosting` nullposting{ptransaction=Just nulltransaction{ttags=[("txntag","")]}} assertBool "j" $ not $ (Sym "$") `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- becomes "^$$", ie testing for null symbol assertBool "k" $ (Sym "\\$") `matchesPosting` nullposting{pamount=Mixed [usd 1]} -- have to quote $ for regexpr assertBool "l" $ (Sym "shekels") `matchesPosting` nullposting{pamount=Mixed [amount{acommodity="shekels"}]} assertBool "m" $ not $ (Sym "shek") `matchesPosting` nullposting{pamount=Mixed [amount{acommodity="shekels"}]} ] -- | Does the match expression match this transaction ? matchesTransaction :: Query -> Transaction -> Bool matchesTransaction (Not q) t = not $ q `matchesTransaction` t matchesTransaction (Any) _ = True matchesTransaction (None) _ = False matchesTransaction (Or qs) t = any (`matchesTransaction` t) qs matchesTransaction (And qs) t = all (`matchesTransaction` t) qs matchesTransaction (Code r) t = regexMatchesCI r $ tcode t matchesTransaction (Desc r) t = regexMatchesCI r $ tdescription t matchesTransaction q@(Acct _) t = any (q `matchesPosting`) $ tpostings t matchesTransaction (Date span) t = spanContainsDate span $ tdate t matchesTransaction (Date2 span) t = spanContainsDate span $ transactionDate2 t matchesTransaction (Status v) t = v == tstatus t matchesTransaction (Real v) t = v == hasRealPostings t matchesTransaction q@(Amt _ _) t = any (q `matchesPosting`) $ tpostings t matchesTransaction (Empty _) _ = True matchesTransaction (Depth d) t = any (Depth d `matchesPosting`) $ tpostings t matchesTransaction q@(Sym _) t = any (q `matchesPosting`) $ tpostings t matchesTransaction (Tag n Nothing) t = isJust $ lookupTagByName n $ transactionAllTags t matchesTransaction (Tag n (Just v)) t = isJust $ lookupTagByNameAndValue (n,v) $ transactionAllTags t -- matchesTransaction _ _ = False tests_matchesTransaction = [ "matchesTransaction" ~: do let q `matches` t = assertBool "" $ q `matchesTransaction` t Any `matches` nulltransaction assertBool "" $ not $ (Desc "x x") `matchesTransaction` nulltransaction{tdescription="x"} assertBool "" $ (Desc "x x") `matchesTransaction` nulltransaction{tdescription="x x"} -- see posting for more tag tests assertBool "" $ (Tag "foo" (Just "a")) `matchesTransaction` nulltransaction{ttags=[("foo","bar")]} -- a tag match on a transaction usually ignores posting tags assertBool "" $ not $ (Tag "postingtag" Nothing) `matchesTransaction` nulltransaction{tpostings=[nullposting{ptags=[("postingtag","")]}]} ] lookupTagByName :: String -> [Tag] -> Maybe Tag lookupTagByName namepat tags = headMay [(n,v) | (n,v) <- tags, matchTagName namepat n] lookupTagByNameAndValue :: Tag -> [Tag] -> Maybe Tag lookupTagByNameAndValue (namepat, valpat) tags = headMay [(n,v) | (n,v) <- tags, matchTagName namepat n, matchTagValue valpat v] matchTagName :: String -> String -> Bool matchTagName pat name = pat == name matchTagValue :: String -> String -> Bool matchTagValue pat value = regexMatchesCI pat value -- tests tests_Hledger_Query :: Test tests_Hledger_Query = TestList $ tests_simplifyQuery ++ tests_words'' ++ tests_filterQuery ++ tests_parseQueryTerm ++ tests_parseAmountQueryTerm ++ tests_parseQuery ++ tests_matchesAccount ++ tests_matchesPosting ++ tests_matchesTransaction hledger-lib-0.22/Hledger/Utils.hs0000644000000000000000000005013512252750510015012 0ustar0000000000000000{-# LANGUAGE CPP #-} {-| Standard imports and utilities which are useful everywhere, or needed low in the module hierarchy. This is the bottom of hledger's module graph. -} module Hledger.Utils (---- provide these frequently used modules - or not, for clearer api: -- module Control.Monad, -- module Data.List, -- module Data.Maybe, -- module Data.Time.Calendar, -- module Data.Time.Clock, -- module Data.Time.LocalTime, -- module Data.Tree, -- module Debug.Trace, -- module Text.RegexPR, -- module Test.HUnit, -- module Text.Printf, ---- all of this one: module Hledger.Utils, Debug.Trace.trace, module Data.PPrint, -- module Hledger.Utils.UTF8IOCompat SystemString,fromSystemString,toSystemString,error',userError', ppShow -- the rest need to be done in each module I think ) where import Control.Monad (liftM, when) import Control.Monad.Error (MonadIO) import Control.Monad.IO.Class (liftIO) import Data.Char import Data.Data import Data.List import qualified Data.Map as M import Data.Maybe import Data.PPrint import Data.Time.Clock import Data.Time.LocalTime import Data.Tree import Debug.Trace import Safe (readDef) import System.Directory (getHomeDirectory) import System.Environment (getArgs) import System.Exit import System.FilePath((), isRelative) import System.IO import System.IO.Unsafe (unsafePerformIO) import Test.HUnit import Text.ParserCombinators.Parsec import Text.Printf import Text.Regex import Text.RegexPR import Text.Show.Pretty -- import qualified Data.Map as Map -- -- import Prelude hiding (readFile,writeFile,appendFile,getContents,putStr,putStrLn) -- import Hledger.Utils.UTF8IOCompat (readFile,writeFile,appendFile,getContents,putStr,putStrLn) import Hledger.Utils.UTF8IOCompat (SystemString,fromSystemString,toSystemString,error',userError') -- strings lowercase = map toLower uppercase = map toUpper strip = lstrip . rstrip lstrip = dropWhile (`elem` " \t") :: String -> String rstrip = reverse . lstrip . reverse stripbrackets = dropWhile (`elem` "([") . reverse . dropWhile (`elem` "])") . reverse :: String -> String elideLeft width s = if length s > width then ".." ++ reverse (take (width - 2) $ reverse s) else s elideRight width s = if length s > width then take (width - 2) s ++ ".." else s underline :: String -> String underline s = s' ++ replicate (length s) '-' ++ "\n" where s' | last s == '\n' = s | otherwise = s ++ "\n" -- | Wrap a string in single quotes, and \-prefix any embedded single -- quotes, if it contains whitespace and is not already single- or -- double-quoted. quoteIfSpaced :: String -> String quoteIfSpaced s | isSingleQuoted s || isDoubleQuoted s = s | not $ any (`elem` s) whitespacechars = s | otherwise = "'"++escapeSingleQuotes s++"'" escapeSingleQuotes :: String -> String escapeSingleQuotes = regexReplace "'" "\'" escapeQuotes :: String -> String escapeQuotes = regexReplace "([\"'])" "\\1" -- | Quote-aware version of words - don't split on spaces which are inside quotes. -- NB correctly handles "a'b" but not "''a''". Can raise an error if parsing fails. words' :: String -> [String] words' "" = [] words' s = map stripquotes $ fromparse $ parsewith p s where p = do ss <- (quotedPattern <|> pattern) `sepBy` many1 spacenonewline -- eof return ss pattern = many (noneOf whitespacechars) quotedPattern = between (oneOf "'\"") (oneOf "'\"") $ many $ noneOf "'\"" -- | Quote-aware version of unwords - single-quote strings which contain whitespace unwords' :: [String] -> String unwords' = unwords . map singleQuoteIfNeeded -- | Single-quote this string if it contains whitespace or double-quotes singleQuoteIfNeeded s | any (`elem` s) whitespacechars = "'"++s++"'" | otherwise = s whitespacechars = " \t\n\r" -- | Strip one matching pair of single or double quotes on the ends of a string. stripquotes :: String -> String stripquotes s = if isSingleQuoted s || isDoubleQuoted s then init $ tail s else s isSingleQuoted s@(_:_:_) = head s == '\'' && last s == '\'' isSingleQuoted _ = False isDoubleQuoted s@(_:_:_) = head s == '"' && last s == '"' isDoubleQuoted _ = False unbracket :: String -> String unbracket s | (head s == '[' && last s == ']') || (head s == '(' && last s == ')') = init $ tail s | otherwise = s -- | Join multi-line strings as side-by-side rectangular strings of the same height, top-padded. concatTopPadded :: [String] -> String concatTopPadded strs = intercalate "\n" $ map concat $ transpose padded where lss = map lines strs h = maximum $ map length lss ypad ls = replicate (difforzero h (length ls)) "" ++ ls xpad ls = map (padleft w) ls where w | null ls = 0 | otherwise = maximum $ map length ls padded = map (xpad . ypad) lss -- | Join multi-line strings as side-by-side rectangular strings of the same height, bottom-padded. concatBottomPadded :: [String] -> String concatBottomPadded strs = intercalate "\n" $ map concat $ transpose padded where lss = map lines strs h = maximum $ map length lss ypad ls = ls ++ replicate (difforzero h (length ls)) "" xpad ls = map (padright w) ls where w | null ls = 0 | otherwise = maximum $ map length ls padded = map (xpad . ypad) lss -- | Compose strings vertically and right-aligned. vConcatRightAligned :: [String] -> String vConcatRightAligned ss = intercalate "\n" $ map showfixedwidth ss where showfixedwidth = printf (printf "%%%ds" width) width = maximum $ map length ss -- | Convert a multi-line string to a rectangular string top-padded to the specified height. padtop :: Int -> String -> String padtop h s = intercalate "\n" xpadded where ls = lines s sh = length ls sw | null ls = 0 | otherwise = maximum $ map length ls ypadded = replicate (difforzero h sh) "" ++ ls xpadded = map (padleft sw) ypadded -- | Convert a multi-line string to a rectangular string bottom-padded to the specified height. padbottom :: Int -> String -> String padbottom h s = intercalate "\n" xpadded where ls = lines s sh = length ls sw | null ls = 0 | otherwise = maximum $ map length ls ypadded = ls ++ replicate (difforzero h sh) "" xpadded = map (padleft sw) ypadded -- | Convert a multi-line string to a rectangular string left-padded to the specified width. padleft :: Int -> String -> String padleft w "" = concat $ replicate w " " padleft w s = intercalate "\n" $ map (printf (printf "%%%ds" w)) $ lines s -- | Convert a multi-line string to a rectangular string right-padded to the specified width. padright :: Int -> String -> String padright w "" = concat $ replicate w " " padright w s = intercalate "\n" $ map (printf (printf "%%-%ds" w)) $ lines s -- | Clip a multi-line string to the specified width and height from the top left. cliptopleft :: Int -> Int -> String -> String cliptopleft w h = intercalate "\n" . take h . map (take w) . lines -- | Clip and pad a multi-line string to fill the specified width and height. fitto :: Int -> Int -> String -> String fitto w h s = intercalate "\n" $ take h $ rows ++ repeat blankline where rows = map (fit w) $ lines s fit w = take w . (++ repeat ' ') blankline = replicate w ' ' -- math difforzero :: (Num a, Ord a) => a -> a -> a difforzero a b = maximum [(a - b), 0] -- regexps -- Note many of these will die on malformed regexps. -- regexMatch :: String -> String -> MatchFun Maybe regexMatch r s = matchRegexPR r s -- regexMatchCI :: String -> String -> MatchFun Maybe regexMatchCI r s = regexMatch (regexToCaseInsensitive r) s regexMatches :: String -> String -> Bool regexMatches r s = isJust $ matchRegexPR r s regexMatchesCI :: String -> String -> Bool regexMatchesCI r s = regexMatches (regexToCaseInsensitive r) s containsRegex = regexMatchesCI regexReplace :: String -> String -> String -> String regexReplace r repl s = gsubRegexPR r repl s regexReplaceCI :: String -> String -> String -> String regexReplaceCI r s = regexReplace (regexToCaseInsensitive r) s regexReplaceBy :: String -> (String -> String) -> String -> String regexReplaceBy r replfn s = gsubRegexPRBy r replfn s regexToCaseInsensitive :: String -> String regexToCaseInsensitive r = "(?i)"++ r regexSplit :: String -> String -> [String] regexSplit = splitRegexPR -- regex-compat (regex-posix) functions that perform better than regexpr. regexMatchesRegexCompat :: String -> String -> Bool regexMatchesRegexCompat r = isJust . matchRegex (mkRegex r) regexMatchesCIRegexCompat :: String -> String -> Bool regexMatchesCIRegexCompat r = isJust . matchRegex (mkRegexWithOpts r True False) -- lists splitAtElement :: Eq a => a -> [a] -> [[a]] splitAtElement e l = case dropWhile (e==) l of [] -> [] l' -> first : splitAtElement e rest where (first,rest) = break (e==) l' -- trees -- standard tree helpers root = rootLabel subs = subForest branches = subForest -- | List just the leaf nodes of a tree leaves :: Tree a -> [a] leaves (Node v []) = [v] leaves (Node _ branches) = concatMap leaves branches -- | get the sub-tree rooted at the first (left-most, depth-first) occurrence -- of the specified node value subtreeat :: Eq a => a -> Tree a -> Maybe (Tree a) subtreeat v t | root t == v = Just t | otherwise = subtreeinforest v $ subs t -- | get the sub-tree for the specified node value in the first tree in -- forest in which it occurs. subtreeinforest :: Eq a => a -> [Tree a] -> Maybe (Tree a) subtreeinforest _ [] = Nothing subtreeinforest v (t:ts) = case (subtreeat v t) of Just t' -> Just t' Nothing -> subtreeinforest v ts -- | remove all nodes past a certain depth treeprune :: Int -> Tree a -> Tree a treeprune 0 t = Node (root t) [] treeprune d t = Node (root t) (map (treeprune $ d-1) $ branches t) -- | apply f to all tree nodes treemap :: (a -> b) -> Tree a -> Tree b treemap f t = Node (f $ root t) (map (treemap f) $ branches t) -- | remove all subtrees whose nodes do not fulfill predicate treefilter :: (a -> Bool) -> Tree a -> Tree a treefilter f t = Node (root t) (map (treefilter f) $ filter (treeany f) $ branches t) -- | is predicate true in any node of tree ? treeany :: (a -> Bool) -> Tree a -> Bool treeany f t = f (root t) || any (treeany f) (branches t) -- treedrop -- remove the leaves which do fulfill predicate. -- treedropall -- do this repeatedly. -- | show a compact ascii representation of a tree showtree :: Show a => Tree a -> String showtree = unlines . filter (regexMatches "[^ \\|]") . lines . drawTree . treemap show -- | show a compact ascii representation of a forest showforest :: Show a => Forest a -> String showforest = concatMap showtree -- | An efficient-to-build tree suggested by Cale Gibbard, probably -- better than accountNameTreeFrom. newtype FastTree a = T (M.Map a (FastTree a)) deriving (Show, Eq, Ord) emptyTree = T M.empty mergeTrees :: (Ord a) => FastTree a -> FastTree a -> FastTree a mergeTrees (T m) (T m') = T (M.unionWith mergeTrees m m') treeFromPath :: [a] -> FastTree a treeFromPath [] = T M.empty treeFromPath (x:xs) = T (M.singleton x (treeFromPath xs)) treeFromPaths :: (Ord a) => [[a]] -> FastTree a treeFromPaths = foldl' mergeTrees emptyTree . map treeFromPath -- debugging -- more: -- http://hackage.haskell.org/packages/archive/TraceUtils/0.1.0.2/doc/html/Debug-TraceUtils.html -- http://hackage.haskell.org/packages/archive/trace-call/0.1/doc/html/Debug-TraceCall.html -- http://hackage.haskell.org/packages/archive/htrace/0.1/doc/html/Debug-HTrace.html -- http://hackage.haskell.org/packages/archive/traced/2009.7.20/doc/html/Debug-Traced.html -- | Trace (print on stdout at runtime) a showable value. -- (for easily tracing in the middle of a complex expression) strace :: Show a => a -> a strace a = trace (show a) a -- | Labelled trace - like strace, with a label prepended. ltrace :: Show a => String -> a -> a ltrace l a = trace (l ++ ": " ++ show a) a -- | Monadic trace - like strace, but works as a standalone line in a monad. mtrace :: (Monad m, Show a) => a -> m a mtrace a = strace a `seq` return a -- | Custom trace - like strace, with a custom show function. traceWith :: (a -> String) -> a -> a traceWith f e = trace (f e) e -- | Parsec trace - show the current parsec position and next input, -- and the provided label if it's non-null. ptrace :: String -> GenParser Char st () ptrace msg = do pos <- getPosition next <- take peeklength `fmap` getInput let (l,c) = (sourceLine pos, sourceColumn pos) s = printf "at line %2d col %2d: %s" l c (show next) :: String s' = printf ("%-"++show (peeklength+30)++"s") s ++ " " ++ msg trace s' $ return () where peeklength = 30 -- | Global debug level, which controls the verbosity of debug output -- on the console. The default is 0 meaning no debug output. The -- @--debug@ command line flag sets it to 1, or @--debug=N@ sets it to -- a higher value (note: not @--debug N@ for some reason). This uses -- unsafePerformIO and can be accessed from anywhere and before normal -- command-line processing. After command-line processing, it is also -- available as the @debug_@ field of 'Hledger.Cli.Options.CliOpts'. debugLevel :: Int debugLevel = case snd $ break (=="--debug") args of "--debug":[] -> 1 "--debug":n:_ -> readDef 1 n _ -> case take 1 $ filter ("--debug" `isPrefixOf`) args of ['-':'-':'d':'e':'b':'u':'g':'=':v] -> readDef 1 v _ -> 0 where args = unsafePerformIO getArgs -- | Print a message and a showable value to the console if the global -- debug level is non-zero. Uses unsafePerformIO. dbg :: Show a => String -> a -> a dbg = dbgppshow 1 -- | Print a showable value to the console, with a message, if the -- debug level is at or above the specified level (uses -- unsafePerformIO). -- Values are displayed with show, all on one line, which is hard to read. dbgshow :: Show a => Int -> String -> a -> a dbgshow level | debugLevel >= level = ltrace | otherwise = flip const -- | Print a showable value to the console, with a message, if the -- debug level is at or above the specified level (uses -- unsafePerformIO). -- Values are displayed with ppShow, each field/constructor on its own line. dbgppshow :: Show a => Int -> String -> a -> a dbgppshow level | debugLevel >= level = \s -> traceWith (((s++": ")++) . ppShow) | otherwise = flip const -- | Print a showable value to the console, with a message, if the -- debug level is at or above the specified level (uses -- unsafePerformIO). -- Values are displayed with pprint. Field names are not shown, but the -- output is compact with smart line wrapping, long data elided, -- and slow calculations timed out. dbgpprint :: Data a => Int -> String -> a -> a dbgpprint level msg a | debugLevel >= level = unsafePerformIO $ do pprint a >>= putStrLn . ((msg++": \n") ++) . show return a | otherwise = a -- | Like dbg, then exit the program. Uses unsafePerformIO. dbgExit :: Show a => String -> a -> a dbgExit msg = const (unsafePerformIO exitFailure) . dbg msg -- | Print a message and parsec debug info (parse position and next -- input) to the console when the debug level is at or above -- this level. Uses unsafePerformIO. -- pdbgAt :: GenParser m => Float -> String -> m () pdbg level msg = when (level <= debugLevel) $ ptrace msg -- parsing -- | Backtracking choice, use this when alternatives share a prefix. -- Consumes no input if all choices fail. choice' :: [GenParser tok st a] -> GenParser tok st a choice' = choice . map Text.ParserCombinators.Parsec.try parsewith :: Parser a -> String -> Either ParseError a parsewith p = parse p "" parseWithCtx :: b -> GenParser Char b a -> String -> Either ParseError a parseWithCtx ctx p = runParser p ctx "" fromparse :: Either ParseError a -> a fromparse = either parseerror id parseerror :: ParseError -> a parseerror e = error' $ showParseError e showParseError :: ParseError -> String showParseError e = "parse error at " ++ show e showDateParseError :: ParseError -> String showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e) nonspace :: GenParser Char st Char nonspace = satisfy (not . isSpace) spacenonewline :: GenParser Char st Char spacenonewline = satisfy (`elem` " \v\f\t") restofline :: GenParser Char st String restofline = anyChar `manyTill` newline eolof :: GenParser Char st () eolof = (newline >> return ()) <|> eof -- time getCurrentLocalTime :: IO LocalTime getCurrentLocalTime = do t <- getCurrentTime tz <- getCurrentTimeZone return $ utcToLocalTime tz t -- testing -- | Get a Test's label, or the empty string. testName :: Test -> String testName (TestLabel n _) = n testName _ = "" -- | Flatten a Test containing TestLists into a list of single tests. flattenTests :: Test -> [Test] flattenTests (TestLabel _ t@(TestList _)) = flattenTests t flattenTests (TestList ts) = concatMap flattenTests ts flattenTests t = [t] -- | Filter TestLists in a Test, recursively, preserving the structure. filterTests :: (Test -> Bool) -> Test -> Test filterTests p (TestLabel l ts) = TestLabel l (filterTests p ts) filterTests p (TestList ts) = TestList $ filter (any p . flattenTests) $ map (filterTests p) ts filterTests _ t = t -- | Simple way to assert something is some expected value, with no label. is :: (Eq a, Show a) => a -> a -> Assertion a `is` e = assertEqual "" e a -- | Assert a parse result is successful, printing the parse error on failure. assertParse :: (Either ParseError a) -> Assertion assertParse parse = either (assertFailure.show) (const (return ())) parse -- | Assert a parse result is successful, printing the parse error on failure. assertParseFailure :: (Either ParseError a) -> Assertion assertParseFailure parse = either (const $ return ()) (const $ assertFailure "parse should not have succeeded") parse -- | Assert a parse result is some expected value, printing the parse error on failure. assertParseEqual :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion assertParseEqual parse expected = either (assertFailure.show) (`is` expected) parse printParseError :: (Show a) => a -> IO () printParseError e = do putStr "parse error at "; print e -- misc isLeft :: Either a b -> Bool isLeft (Left _) = True isLeft _ = False isRight :: Either a b -> Bool isRight = not . isLeft -- | Apply a function the specified number of times. Possibly uses O(n) stack ? applyN :: Int -> (a -> a) -> a -> a applyN n f = (!! n) . iterate f -- | Convert a possibly relative, possibly tilde-containing file path to an absolute one, -- given the current directory. ~username is not supported. Leave "-" unchanged. expandPath :: MonadIO m => FilePath -> FilePath -> m FilePath -- general type sig for use in reader parsers expandPath _ "-" = return "-" expandPath curdir p = (if isRelative p then (curdir ) else id) `liftM` expandPath' p where expandPath' ('~':'/':p) = liftIO $ ( p) `fmap` getHomeDirectory expandPath' ('~':'\\':p) = liftIO $ ( p) `fmap` getHomeDirectory expandPath' ('~':_) = error' "~USERNAME in paths is not supported" expandPath' p = return p firstJust ms = case dropWhile (==Nothing) ms of [] -> Nothing (md:_) -> md -- | Read a file in universal newline mode, handling whatever newline convention it may contain. readFile' :: FilePath -> IO String readFile' name = do h <- openFile name ReadMode hSetNewlineMode h universalNewlineMode hGetContents h hledger-lib-0.22/Hledger/Reports.hs0000644000000000000000000016344112252750510015355 0ustar0000000000000000{-# LANGUAGE RecordWildCards, DeriveDataTypeable, FlexibleInstances #-} {-| Generate several common kinds of report from a journal, as \"*Report\" - simple intermediate data structures intended to be easily rendered as text, html, json, csv etc. by hledger commands, hamlet templates, javascript, or whatever. -} module Hledger.Reports ( -- * Report options -- | ReportOpts(..), BalanceType(..), DisplayExp, FormatStr, defreportopts, dateSpanFromOpts, intervalFromOpts, clearedValueFromOpts, whichDateFromOpts, journalSelectingAmountFromOpts, queryFromOpts, queryOptsFromOpts, reportSpans, -- * Entries report -- | EntriesReport, EntriesReportItem, entriesReport, -- * Postings report -- | PostingsReport, PostingsReportItem, postingsReport, mkpostingsReportItem, -- XXX for showPostingWithBalanceForVty in Hledger.Cli.Register -- * Transactions report -- | TransactionsReport, TransactionsReportItem, triDate, triBalance, triSimpleBalance, transactionsReportByCommodity, journalTransactionsReport, accountTransactionsReport, -- * Balance reports {-| These are used for the various modes of the balance command (see "Hledger.Cli.Balance"). -} BalanceReport, BalanceReportItem, balanceReport, MultiBalanceReport(..), MultiBalanceReportItem, RenderableAccountName, periodBalanceReport, cumulativeOrHistoricalBalanceReport, -- * Other reports -- | accountBalanceHistory, -- * Tests tests_Hledger_Reports ) where import Control.Monad import Data.List import Data.Maybe -- import qualified Data.Map as M import Data.Ord import Data.Time.Calendar -- import Data.Tree import Safe (headMay, lastMay) import System.Console.CmdArgs -- for defaults support import Test.HUnit import Text.ParserCombinators.Parsec import Text.Printf import Hledger.Data import Hledger.Read (mamountp') import Hledger.Query import Hledger.Utils ------------------------------------------------------------------------------ -- report options handling -- | Standard options for customising report filtering and output, -- corresponding to hledger's command-line options and query language -- arguments. Used in hledger-lib and above. data ReportOpts = ReportOpts { begin_ :: Maybe Day ,end_ :: Maybe Day ,period_ :: Maybe (Interval,DateSpan) ,cleared_ :: Bool ,uncleared_ :: Bool ,cost_ :: Bool ,depth_ :: Maybe Int ,display_ :: Maybe DisplayExp ,date2_ :: Bool ,empty_ :: Bool ,no_elide_ :: Bool ,real_ :: Bool ,balancetype_ :: BalanceType -- for balance command ,flat_ :: Bool -- for balance command ,drop_ :: Int -- " ,no_total_ :: Bool -- " ,daily_ :: Bool ,weekly_ :: Bool ,monthly_ :: Bool ,quarterly_ :: Bool ,yearly_ :: Bool ,format_ :: Maybe FormatStr ,related_ :: Bool ,average_ :: Bool ,query_ :: String -- all arguments, as a string } deriving (Show, Data, Typeable) type DisplayExp = String type FormatStr = String -- | Which balance is being shown in a multi-column balance report. data BalanceType = PeriodBalance -- ^ The change of balance in each period. | CumulativeBalance -- ^ The accumulated balance at each period's end, starting from zero at the report start date. | HistoricalBalance -- ^ The historical balance at each period's end, starting from the account balances at the report start date. deriving (Eq,Show,Data,Typeable) instance Default BalanceType where def = PeriodBalance defreportopts = ReportOpts def def def def def def def def def def def def def def def def def def def def def def def def def instance Default ReportOpts where def = defreportopts -- | Figure out the date span we should report on, based on any -- begin/end/period options provided. A period option will cause begin and -- end options to be ignored. dateSpanFromOpts :: Day -> ReportOpts -> DateSpan dateSpanFromOpts _ ReportOpts{..} = case period_ of Just (_,span) -> span Nothing -> DateSpan begin_ end_ -- | Figure out the reporting interval, if any, specified by the options. -- --period overrides --daily overrides --weekly overrides --monthly etc. intervalFromOpts :: ReportOpts -> Interval intervalFromOpts ReportOpts{..} = case period_ of Just (interval,_) -> interval Nothing -> i where i | daily_ = Days 1 | weekly_ = Weeks 1 | monthly_ = Months 1 | quarterly_ = Quarters 1 | yearly_ = Years 1 | otherwise = NoInterval -- | Get a maybe boolean representing the last cleared/uncleared option if any. clearedValueFromOpts :: ReportOpts -> Maybe Bool clearedValueFromOpts ReportOpts{..} | cleared_ = Just True | uncleared_ = Just False | otherwise = Nothing -- depthFromOpts :: ReportOpts -> Int -- depthFromOpts opts = min (fromMaybe 99999 $ depth_ opts) (queryDepth $ queryFromOpts nulldate opts) -- | Report which date we will report on based on --date2. whichDateFromOpts :: ReportOpts -> WhichDate whichDateFromOpts ReportOpts{..} = if date2_ then SecondaryDate else PrimaryDate -- | Select the Transaction date accessor based on --date2. transactionDateFn :: ReportOpts -> (Transaction -> Day) transactionDateFn ReportOpts{..} = if date2_ then transactionDate2 else tdate -- | Select the Posting date accessor based on --date2. postingDateFn :: ReportOpts -> (Posting -> Day) postingDateFn ReportOpts{..} = if date2_ then postingDate2 else postingDate -- | Convert this journal's postings' amounts to the cost basis amounts if -- specified by options. journalSelectingAmountFromOpts :: ReportOpts -> Journal -> Journal journalSelectingAmountFromOpts opts | cost_ opts = journalConvertAmountsToCost | otherwise = id -- | Convert report options and arguments to a query. queryFromOpts :: Day -> ReportOpts -> Query queryFromOpts d opts@ReportOpts{..} = simplifyQuery $ And $ [flagsq, argsq] where flagsq = And $ [(if date2_ then Date2 else Date) $ dateSpanFromOpts d opts] ++ (if real_ then [Real True] else []) ++ (if empty_ then [Empty True] else []) -- ? ++ (maybe [] ((:[]) . Status) (clearedValueFromOpts opts)) ++ (maybe [] ((:[]) . Depth) depth_) argsq = fst $ parseQuery d query_ tests_queryFromOpts = [ "queryFromOpts" ~: do assertEqual "" Any (queryFromOpts nulldate defreportopts) assertEqual "" (Acct "a") (queryFromOpts nulldate defreportopts{query_="a"}) assertEqual "" (Desc "a a") (queryFromOpts nulldate defreportopts{query_="desc:'a a'"}) assertEqual "" (Date $ mkdatespan "2012/01/01" "2013/01/01") (queryFromOpts nulldate defreportopts{begin_=Just (parsedate "2012/01/01") ,query_="date:'to 2013'" }) assertEqual "" (Date2 $ mkdatespan "2012/01/01" "2013/01/01") (queryFromOpts nulldate defreportopts{query_="edate:'in 2012'"}) assertEqual "" (Or [Acct "a a", Acct "'b"]) (queryFromOpts nulldate defreportopts{query_="'a a' 'b"}) ] -- | Convert report options and arguments to query options. queryOptsFromOpts :: Day -> ReportOpts -> [QueryOpt] queryOptsFromOpts d ReportOpts{..} = flagsqopts ++ argsqopts where flagsqopts = [] argsqopts = snd $ parseQuery d query_ tests_queryOptsFromOpts = [ "queryOptsFromOpts" ~: do assertEqual "" [] (queryOptsFromOpts nulldate defreportopts) assertEqual "" [] (queryOptsFromOpts nulldate defreportopts{query_="a"}) assertEqual "" [] (queryOptsFromOpts nulldate defreportopts{begin_=Just (parsedate "2012/01/01") ,query_="date:'to 2013'" }) ] ------------------------------------------------------------------------------- -- | A journal entries report is a list of whole transactions as -- originally entered in the journal (mostly). This is used by eg -- hledger's print command and hledger-web's journal entries view. type EntriesReport = [EntriesReportItem] type EntriesReportItem = Transaction -- | Select transactions for an entries report. entriesReport :: ReportOpts -> Query -> Journal -> EntriesReport entriesReport opts q j = sortBy (comparing date) $ filter (q `matchesTransaction`) ts where date = transactionDateFn opts ts = jtxns $ journalSelectingAmountFromOpts opts j tests_entriesReport = [ "entriesReport" ~: do assertEqual "not acct" 1 (length $ entriesReport defreportopts (Not $ Acct "bank") samplejournal) let span = mkdatespan "2008/06/01" "2008/07/01" assertEqual "date" 3 (length $ entriesReport defreportopts (Date $ span) samplejournal) ] ------------------------------------------------------------------------------- -- | A postings report is a list of postings with a running total, a label -- for the total field, and a little extra transaction info to help with rendering. -- This is used eg for the register command. type PostingsReport = (String -- label for the running balance column XXX remove ,[PostingsReportItem] -- line items, one per posting ) type PostingsReportItem = (Maybe Day -- posting date, if this is the first posting in a transaction or if it's different from the previous posting's date ,Maybe String -- transaction description, if this is the first posting in a transaction ,Posting -- the posting, possibly with account name depth-clipped ,MixedAmount -- the running total after this posting (or with --average, the running average) ) -- | Select postings from the journal and add running balance and other -- information to make a postings report. Used by eg hledger's register command. postingsReport :: ReportOpts -> Query -> Journal -> PostingsReport postingsReport opts q j = -- trace ("q: "++show q++"\nq': "++show q') $ (totallabel, postingsReportItems ps nullposting wd depth startbal runningcalcfn 1) where ps | interval == NoInterval = displayableps | otherwise = summarisePostingsByInterval interval depth empty reportspan displayableps j' = journalSelectingAmountFromOpts opts j wd = whichDateFromOpts opts -- delay depth filtering until the end (depth, q') = (queryDepth q, filterQuery (not . queryIsDepth) q) (precedingps, displayableps, _) = dbg "ps4" $ postingsMatchingDisplayExpr displayexpr opts $ dbg "ps3" $ (if related_ opts then concatMap relatedPostings else id) $ dbg "ps2" $ filter (q' `matchesPosting`) $ dbg "ps1" $ journalPostings j' -- enable to debug just this function -- dbg :: Show a => String -> a -> a -- dbg = lstrace empty = queryEmpty q displayexpr = display_ opts -- XXX interval = intervalFromOpts opts -- XXX journalspan = journalDateSpan j' -- requestedspan should be the intersection of any span specified -- with period options and any span specified with display option. -- The latter is not easily available, fake it for now. requestedspan = periodspan `spanIntersect` displayspan periodspan = queryDateSpan secondarydate q secondarydate = whichDateFromOpts opts == SecondaryDate displayspan = postingsDateSpan ps where (_,ps,_) = postingsMatchingDisplayExpr displayexpr opts $ journalPostings j' matchedspan = postingsDateSpan displayableps reportspan | empty = requestedspan `orDatesFrom` journalspan | otherwise = requestedspan `spanIntersect` matchedspan startbal = sumPostings precedingps runningcalcfn | average_ opts = \i avg amt -> avg + (amt - avg) `divideMixedAmount` (fromIntegral i) | otherwise = \_ bal amt -> bal + amt totallabel = "Total" balancelabel = "Balance" -- | Generate postings report line items. postingsReportItems :: [Posting] -> Posting -> WhichDate -> Int -> MixedAmount -> (Int -> MixedAmount -> MixedAmount -> MixedAmount) -> Int -> [PostingsReportItem] postingsReportItems [] _ _ _ _ _ _ = [] postingsReportItems (p:ps) pprev wd d b runningcalcfn itemnum = i:(postingsReportItems ps p wd d b' runningcalcfn (itemnum+1)) where i = mkpostingsReportItem showdate showdesc wd p' b' showdate = isfirstintxn || isdifferentdate showdesc = isfirstintxn isfirstintxn = ptransaction p /= ptransaction pprev isdifferentdate = case wd of PrimaryDate -> postingDate p /= postingDate pprev SecondaryDate -> postingDate2 p /= postingDate2 pprev p' = p{paccount=clipAccountName d $ paccount p} b' = runningcalcfn itemnum b (pamount p) -- | Generate one postings report line item, containing the posting, -- the current running balance, and optionally the posting date and/or -- the transaction description. mkpostingsReportItem :: Bool -> Bool -> WhichDate -> Posting -> MixedAmount -> PostingsReportItem mkpostingsReportItem showdate showdesc wd p b = (if showdate then Just date else Nothing, if showdesc then Just desc else Nothing, p, b) where date = case wd of PrimaryDate -> postingDate p SecondaryDate -> postingDate2 p desc = maybe "" tdescription $ ptransaction p -- | Date-sort and split a list of postings into three spans - postings matched -- by the given display expression, and the preceding and following postings. -- XXX always sorts by primary date, should sort by secondary date if expression is about that postingsMatchingDisplayExpr :: Maybe String -> ReportOpts -> [Posting] -> ([Posting],[Posting],[Posting]) postingsMatchingDisplayExpr d opts ps = (before, matched, after) where sorted = sortBy (comparing (postingDateFn opts)) ps (before, rest) = break (displayExprMatches d) sorted (matched, after) = span (displayExprMatches d) rest -- | Does this display expression allow this posting to be displayed ? -- Raises an error if the display expression can't be parsed. displayExprMatches :: Maybe String -> Posting -> Bool displayExprMatches Nothing _ = True displayExprMatches (Just d) p = (fromparse $ parsewith datedisplayexpr d) p -- | Parse a hledger display expression, which is a simple date test like -- "d>[DATE]" or "d<=[DATE]", and return a "Posting"-matching predicate. datedisplayexpr :: GenParser Char st (Posting -> Bool) datedisplayexpr = do char 'd' op <- compareop char '[' (y,m,d) <- smartdate char ']' let date = parsedate $ printf "%04s/%02s/%02s" y m d test op = return $ (`op` date) . postingDate case op of "<" -> test (<) "<=" -> test (<=) "=" -> test (==) "==" -> test (==) ">=" -> test (>=) ">" -> test (>) _ -> mzero where compareop = choice $ map (try . string) ["<=",">=","==","<","=",">"] -- -- | Clip the account names to the specified depth in a list of postings. -- depthClipPostings :: Maybe Int -> [Posting] -> [Posting] -- depthClipPostings depth = map (depthClipPosting depth) -- -- | Clip a posting's account name to the specified depth. -- depthClipPosting :: Maybe Int -> Posting -> Posting -- depthClipPosting Nothing p = p -- depthClipPosting (Just d) p@Posting{paccount=a} = p{paccount=clipAccountName d a} -- XXX confusing, refactor -- | Convert a list of postings into summary postings. Summary postings -- are one per account per interval and aggregated to the specified depth -- if any. summarisePostingsByInterval :: Interval -> Int -> Bool -> DateSpan -> [Posting] -> [Posting] summarisePostingsByInterval interval depth empty reportspan ps = concatMap summarisespan $ splitSpan interval reportspan where summarisespan s = summarisePostingsInDateSpan s depth empty (postingsinspan s) postingsinspan s = filter (isPostingInDateSpan s) ps tests_summarisePostingsByInterval = [ "summarisePostingsByInterval" ~: do summarisePostingsByInterval (Quarters 1) 99999 False (DateSpan Nothing Nothing) [] ~?= [] ] -- | Given a date span (representing a reporting interval) and a list of -- postings within it: aggregate the postings so there is only one per -- account, and adjust their date/description so that they will render -- as a summary for this interval. -- -- As usual with date spans the end date is exclusive, but for display -- purposes we show the previous day as end date, like ledger. -- -- When a depth argument is present, postings to accounts of greater -- depth are aggregated where possible. -- -- The showempty flag includes spans with no postings and also postings -- with 0 amount. summarisePostingsInDateSpan :: DateSpan -> Int -> Bool -> [Posting] -> [Posting] summarisePostingsInDateSpan (DateSpan b e) depth showempty ps | null ps && (isNothing b || isNothing e) = [] | null ps && showempty = [summaryp] | otherwise = summaryps' where summaryp = summaryPosting b' ("- "++ showDate (addDays (-1) e')) b' = fromMaybe (maybe nulldate postingDate $ headMay ps) b e' = fromMaybe (maybe (addDays 1 nulldate) postingDate $ lastMay ps) e summaryPosting date desc = nullposting{ptransaction=Just nulltransaction{tdate=date,tdescription=desc}} summaryps' = (if showempty then id else filter (not . isZeroMixedAmount . pamount)) summaryps summaryps = [summaryp{paccount=a,pamount=balance a} | a <- clippedanames] clippedanames = nub $ map (clipAccountName depth) anames anames = sort $ nub $ map paccount ps -- aggregate balances by account, like ledgerFromJournal, then do depth-clipping accts = accountsFromPostings ps balance a = maybe nullmixedamt bal $ lookupAccount a accts where bal = if isclipped a then aibalance else aebalance isclipped a = accountNameLevel a >= depth ------------------------------------------------------------------------------- -- | A transactions report includes a list of transactions -- (posting-filtered and unfiltered variants), a running balance, and some -- other information helpful for rendering a register view (a flag -- indicating multiple other accounts and a display string describing -- them) with or without a notion of current account(s). -- Two kinds of report use this data structure, see journalTransactionsReport -- and accountTransactionsReport below for detais. type TransactionsReport = (String -- label for the balance column, eg "balance" or "total" ,[TransactionsReportItem] -- line items, one per transaction ) type TransactionsReportItem = (Transaction -- the corresponding transaction ,Transaction -- the transaction with postings to the current account(s) removed ,Bool -- is this a split, ie more than one other account posting ,String -- a display string describing the other account(s), if any ,MixedAmount -- the amount posted to the current account(s) (or total amount posted) ,MixedAmount -- the running balance for the current account(s) after this transaction ) triDate (t,_,_,_,_,_) = tdate t triAmount (_,_,_,_,a,_) = a triBalance (_,_,_,_,_,a) = a triSimpleBalance (_,_,_,_,_,Mixed a) = case a of [] -> "0" (Amount{aquantity=q}):_ -> show q -- Split a transactions report whose items may involve several commodities, -- into one or more single-commodity transactions reports. transactionsReportByCommodity :: TransactionsReport -> [TransactionsReport] transactionsReportByCommodity tr = [filterTransactionsReportByCommodity c tr | c <- transactionsReportCommodities tr] where transactionsReportCommodities (_,items) = nub $ sort $ map acommodity $ concatMap (amounts . triAmount) items -- Remove transaction report items and item amount (and running -- balance amount) components that don't involve the specified -- commodity. Other item fields such as the transaction are left unchanged. filterTransactionsReportByCommodity :: Commodity -> TransactionsReport -> TransactionsReport filterTransactionsReportByCommodity c (label,items) = (label, fixTransactionsReportItemBalances $ concat [filterTransactionsReportItemByCommodity c i | i <- items]) where filterTransactionsReportItemByCommodity c (t,t2,s,o,a,bal) | c `elem` cs = [item'] | otherwise = [] where cs = map acommodity $ amounts a item' = (t,t2,s,o,a',bal) a' = filterMixedAmountByCommodity c a fixTransactionsReportItemBalances [] = [] fixTransactionsReportItemBalances [i] = [i] fixTransactionsReportItemBalances items = reverse $ i:(go startbal is) where i:is = reverse items startbal = filterMixedAmountByCommodity c $ triBalance i go _ [] = [] go bal ((t,t2,s,o,amt,_):is) = (t,t2,s,o,amt,bal'):go bal' is where bal' = bal + amt -- | Filter out all but the specified commodity from this amount. filterMixedAmountByCommodity :: Commodity -> MixedAmount -> MixedAmount filterMixedAmountByCommodity c (Mixed as) = Mixed $ filter ((==c). acommodity) as -- | Select transactions from the whole journal. This is similar to a -- "postingsReport" except with transaction-based report items which -- are ordered most recent first. This is used by eg hledger-web's journal view. journalTransactionsReport :: ReportOpts -> Journal -> Query -> TransactionsReport journalTransactionsReport _ Journal{jtxns=ts} m = (totallabel, items) where ts' = sortBy (comparing tdate) $ filter (not . null . tpostings) $ map (filterTransactionPostings m) ts items = reverse $ accountTransactionsReportItems m Nothing nullmixedamt id ts' -- XXX items' first element should be the full transaction with all postings ------------------------------------------------------------------------------- -- | Select transactions within one or more current accounts, and make a -- transactions report relative to those account(s). This means: -- -- 1. it shows transactions from the point of view of the current account(s). -- The transaction amount is the amount posted to the current account(s). -- The other accounts' names are provided. -- -- 2. With no transaction filtering in effect other than a start date, it -- shows the accurate historical running balance for the current account(s). -- Otherwise it shows a running total starting at 0. -- -- This is used by eg hledger-web's account register view. Currently, -- reporting intervals are not supported, and report items are most -- recent first. accountTransactionsReport :: ReportOpts -> Journal -> Query -> Query -> TransactionsReport accountTransactionsReport opts j m thisacctquery = (label, items) where -- transactions affecting this account, in date order ts = sortBy (comparing tdate) $ filter (matchesTransaction thisacctquery) $ jtxns $ journalSelectingAmountFromOpts opts j -- starting balance: if we are filtering by a start date and nothing else, -- the sum of postings to this account before that date; otherwise zero. (startbal,label) | queryIsNull m = (nullmixedamt, balancelabel) | queryIsStartDateOnly (date2_ opts) m = (sumPostings priorps, balancelabel) | otherwise = (nullmixedamt, totallabel) where priorps = -- ltrace "priorps" $ filter (matchesPosting (-- ltrace "priormatcher" $ And [thisacctquery, tostartdatequery])) $ transactionsPostings ts tostartdatequery = Date (DateSpan Nothing startdate) startdate = queryStartDate (date2_ opts) m items = reverse $ accountTransactionsReportItems m (Just thisacctquery) startbal negate ts -- | Generate transactions report items from a list of transactions, -- using the provided query and current account queries, starting balance, -- sign-setting function and balance-summing function. accountTransactionsReportItems :: Query -> Maybe Query -> MixedAmount -> (MixedAmount -> MixedAmount) -> [Transaction] -> [TransactionsReportItem] accountTransactionsReportItems _ _ _ _ [] = [] accountTransactionsReportItems query thisacctquery bal signfn (t:ts) = -- This is used for both accountTransactionsReport and journalTransactionsReport, -- which makes it a bit overcomplicated case i of Just i' -> i':is Nothing -> is where tmatched@Transaction{tpostings=psmatched} = filterTransactionPostings query t (psthisacct,psotheracct) = case thisacctquery of Just m -> partition (matchesPosting m) psmatched Nothing -> ([],psmatched) numotheraccts = length $ nub $ map paccount psotheracct amt = negate $ sum $ map pamount psthisacct acct | isNothing thisacctquery = summarisePostings psmatched -- journal register | numotheraccts == 0 = "transfer between " ++ summarisePostingAccounts psthisacct | otherwise = prefix ++ summarisePostingAccounts psotheracct where prefix = maybe "" (\b -> if b then "from " else "to ") $ isNegativeMixedAmount amt (i,bal') = case psmatched of [] -> (Nothing,bal) _ -> (Just (t, tmatched, numotheraccts > 1, acct, a, b), b) where a = signfn amt b = bal + a is = accountTransactionsReportItems query thisacctquery bal' signfn ts -- | Generate a short readable summary of some postings, like -- "from (negatives) to (positives)". summarisePostings :: [Posting] -> String summarisePostings ps = case (summarisePostingAccounts froms, summarisePostingAccounts tos) of ("",t) -> "to "++t (f,"") -> "from "++f (f,t) -> "from "++f++" to "++t where (froms,tos) = partition (fromMaybe False . isNegativeMixedAmount . pamount) ps -- | Generate a simplified summary of some postings' accounts. summarisePostingAccounts :: [Posting] -> String summarisePostingAccounts = intercalate ", " . map accountLeafName . nub . map paccount filterTransactionPostings :: Query -> Transaction -> Transaction filterTransactionPostings m t@Transaction{tpostings=ps} = t{tpostings=filter (m `matchesPosting`) ps} ------------------------------------------------------------------------------- -- | A list of account names plus rendering info, along with their -- balances as of the end of the reporting period, and the grand -- total. Used for the balance command's single-column mode. type BalanceReport = ([BalanceReportItem] -- line items, one per account ,MixedAmount -- total balance of all accounts ) -- | * Full account name, -- -- * short account name for display (the leaf name, prefixed by any boring parents immediately above), -- -- * how many steps to indent this account (the 0-based account depth excluding boring parents, or 0 with --flat), -- -- * account balance (including subaccounts (XXX unless --flat)). type BalanceReportItem = (AccountName ,AccountName ,Int ,MixedAmount) -- | Select accounts, and get their balances at the end of the selected -- period, and misc. display information, for an accounts report. balanceReport :: ReportOpts -> Query -> Journal -> BalanceReport balanceReport opts q j = (items, total) where l = ledgerFromJournal q $ journalSelectingAmountFromOpts opts j accts = clipAccounts (queryDepth q) $ ledgerRootAccount l accts' | flat_ opts = filterzeros $ tail $ flattenAccounts accts | otherwise = filter (not.aboring) $ tail $ flattenAccounts $ markboring $ prunezeros accts where filterzeros | empty_ opts = id | otherwise = filter (not . isZeroMixedAmount . aebalance) prunezeros | empty_ opts = id | otherwise = fromMaybe nullacct . pruneAccounts (isZeroMixedAmount.aibalance) markboring | no_elide_ opts = id | otherwise = markBoringParentAccounts items = map (balanceReportItem opts) accts' total = sum [amt | (a,_,indent,amt) <- items, if flat_ opts then accountNameLevel a == 1 else indent == 0] -- XXX check account level == 1 is valid when top-level accounts excluded -- | In an account tree with zero-balance leaves removed, mark the -- elidable parent accounts (those with one subaccount and no balance -- of their own). markBoringParentAccounts :: Account -> Account markBoringParentAccounts = tieAccountParents . mapAccounts mark where mark a | length (asubs a) == 1 && isZeroMixedAmount (aebalance a) = a{aboring=True} | otherwise = a balanceReportItem :: ReportOpts -> Account -> BalanceReportItem balanceReportItem opts a@Account{aname=name, aibalance=ibal} | flat_ opts = (name, name, 0, ibal) | otherwise = (name, elidedname, indent, ibal) where elidedname = accountNameFromComponents (adjacentboringparentnames ++ [accountLeafName name]) adjacentboringparentnames = reverse $ map (accountLeafName.aname) $ takeWhile aboring $ parents indent = length $ filter (not.aboring) parents parents = init $ parentAccounts a ------------------------------------------------------------------------------- -- | A multi(column) balance report is a list of accounts, each with a list of -- balances corresponding to the report's column periods. The balances' meaning depends -- on the type of balance report (see 'BalanceType' and "Hledger.Cli.Balance"). -- Also included are the overall total for each period, the date span for each period, -- and some additional rendering info for the accounts. -- -- * The date span for each report column, -- -- * line items (one per account), -- -- * the final total for each report column. newtype MultiBalanceReport = MultiBalanceReport ([DateSpan] ,[MultiBalanceReportItem] ,[MixedAmount] ) -- | * The account name with rendering hints, -- -- * the account's balance (per-period balance, cumulative ending -- balance, or historical ending balance) in each of the report's -- periods. type MultiBalanceReportItem = (RenderableAccountName ,[MixedAmount] ) -- | * Full account name, -- -- * ledger-style short account name (the leaf name, prefixed by any boring parents immediately above), -- -- * indentation steps to use when rendering a ledger-style account tree -- (the 0-based depth of this account excluding boring parents; or with --flat, 0) type RenderableAccountName = (AccountName ,AccountName ,Int ) instance Show MultiBalanceReport where -- use ppShow to break long lists onto multiple lines -- we have to add some bogus extra shows here to help ppShow parse the output -- and wrap tuples and lists properly show (MultiBalanceReport (spans, items, totals)) = "MultiBalanceReport (ignore extra quotes):\n" ++ ppShow (show spans, map show items, totals) -- | Select accounts and get their period balance (change of balance) in each -- period, plus misc. display information, for a period balance report. periodBalanceReport :: ReportOpts -> Query -> Journal -> MultiBalanceReport periodBalanceReport opts q j = MultiBalanceReport (spans, items, totals) where (q',depthq) = (filterQuery (not . queryIsDepth) q, filterQuery queryIsDepth q) clip = filter (depthq `matchesAccount`) j' = filterJournalPostings q' $ journalSelectingAmountFromOpts opts j ps = journalPostings j' -- the requested span is the span of the query (which is -- based on -b/-e/-p opts and query args IIRC). requestedspan = queryDateSpan (date2_ opts) q -- the report's span will be the requested span intersected with -- the selected data's span; or with -E, the requested span -- limited by the journal's overall span. reportspan | empty_ opts = requestedspan `orDatesFrom` journalspan | otherwise = requestedspan `spanIntersect` matchedspan where journalspan = journalDateSpan j' matchedspan = postingsDateSpan ps -- first implementation, probably inefficient spans = dbg "1 " $ splitSpan (intervalFromOpts opts) reportspan psPerSpan = dbg "3" $ [filter (isPostingInDateSpan s) ps | s <- spans] acctnames = dbg "4" $ sort $ clip $ -- expandAccountNames $ accountNamesFromPostings ps allAcctsZeros = dbg "5" $ [(a, nullmixedamt) | a <- acctnames] someAcctBalsPerSpan = dbg "6" $ [[(aname a, aibalance a) | a <- drop 1 $ accountsFromPostings ps, depthq `matchesAccount` aname a, aname a `elem` acctnames] | ps <- psPerSpan] balsPerSpan = dbg "7" $ [sortBy (comparing fst) $ unionBy (\(a,_) (a',_) -> a == a') acctbals allAcctsZeros | acctbals <- someAcctBalsPerSpan] balsPerAcct = dbg "8" $ transpose balsPerSpan acctsAndBals = dbg "8.5" $ zip acctnames (map (map snd) balsPerAcct) items = dbg "9" $ [((a, a, accountNameLevel a), bs) | (a,bs) <- acctsAndBals, empty_ opts || any (not . isZeroMixedAmount) bs] highestLevelBalsPerSpan = dbg "9.5" $ [[b | (a,b) <- spanbals, not $ any (`elem` acctnames) $ init $ expandAccountName a] | spanbals <- balsPerSpan] totals = dbg "10" $ map sum highestLevelBalsPerSpan ------------------------------------------------------------------------------- -- | Calculate the overall span and per-period date spans for a report -- based on command-line options, the parsed search query, and the -- journal data. If a reporting interval is specified, the report span -- will be enlarged to include a whole number of report periods. -- Reports will sometimes trim these spans further when appropriate. reportSpans :: ReportOpts -> Query -> Journal -> (DateSpan, [DateSpan]) reportSpans opts q j = (reportspan, spans) where -- get the requested span from the query, which is based on -- -b/-e/-p opts and query args. requestedspan = queryDateSpan (date2_ opts) q -- set the start and end date to the journal's if not specified requestedspan' = requestedspan `orDatesFrom` journalDateSpan j -- if there's a reporting interval, calculate the report periods -- which enclose the requested span spans = dbg "spans" $ splitSpan (intervalFromOpts opts) requestedspan' -- the overall report span encloses the periods reportspan = DateSpan (maybe Nothing spanStart $ headMay spans) (maybe Nothing spanEnd $ lastMay spans) -- | Select accounts and get their ending balance in each period, plus -- account name display information, for a cumulative or historical balance report. cumulativeOrHistoricalBalanceReport :: ReportOpts -> Query -> Journal -> MultiBalanceReport cumulativeOrHistoricalBalanceReport opts q j = MultiBalanceReport (periodbalancespans, items, totals) where -- select/adjust basic report dates (reportspan, _) = reportSpans opts q j -- rewrite query to use adjusted dates dateless = filterQuery (not . queryIsDate) depthless = filterQuery (not . queryIsDepth) q' = dateless $ depthless q -- reportq = And [q', Date reportspan] -- get starting balances and accounts from preceding txns precedingq = And [q', Date $ DateSpan Nothing (spanStart reportspan)] (startbalanceitems,_) = balanceReport opts{flat_=True,empty_=True} precedingq j startacctbals = dbg "startacctbals" $ map (\(a,_,_,b) -> (a,b)) startbalanceitems -- acctsWithStartingBalance = map fst $ filter (not . isZeroMixedAmount . snd) startacctbals startingBalanceFor a | balancetype_ opts == HistoricalBalance = fromMaybe nullmixedamt $ lookup a startacctbals | otherwise = nullmixedamt -- get balance changes by period MultiBalanceReport (periodbalancespans,periodbalanceitems,_) = dbg "changes" $ periodBalanceReport opts q j balanceChangesByAcct = map (\((a,_,_),bs) -> (a,bs)) periodbalanceitems acctsWithBalanceChanges = map fst $ filter ((any (not . isZeroMixedAmount)) . snd) balanceChangesByAcct balanceChangesFor a = fromMaybe (error $ "no data for account: a") $ -- XXX lookup a balanceChangesByAcct -- accounts to report on reportaccts -- = dbg' "reportaccts" $ (dbg' "acctsWithStartingBalance" acctsWithStartingBalance) `union` (dbg' "acctsWithBalanceChanges" acctsWithBalanceChanges) = acctsWithBalanceChanges -- sum balance changes to get ending balances for each period endingBalancesFor a = dbg "ending balances" $ drop 1 $ scanl (+) (startingBalanceFor a) $ dbg "balance changes" $ balanceChangesFor a items = dbg "items" $ [((a,a,0), endingBalancesFor a) | a <- reportaccts] -- sum highest-level account balances in each column for column totals totals = dbg "totals" $ map sum highestlevelbalsbycol where highestlevelbalsbycol = transpose $ map endingBalancesFor highestlevelaccts highestlevelaccts = dbg "highestlevelaccts" $ [a | a <- reportaccts, not $ any (`elem` reportaccts) $ init $ expandAccountName a] -- enable to debug just this function -- dbg :: Show a => String -> a -> a -- dbg = lstrace ------------------------------------------------------------------------------- -- | Get the historical running inclusive balance of a particular account, -- from earliest to latest posting date. -- XXX Accounts should know the Ledger & Journal they came from accountBalanceHistory :: ReportOpts -> Journal -> Account -> [(Day, MixedAmount)] accountBalanceHistory ropts j a = [(getdate t, bal) | (t,_,_,_,_,bal) <- items] where (_,items) = journalTransactionsReport ropts j acctquery inclusivebal = True acctquery = Acct $ (if inclusivebal then accountNameToAccountRegex else accountNameToAccountOnlyRegex) $ aname a getdate = if date2_ ropts then transactionDate2 else tdate ------------------------------------------------------------------------------- -- TESTS tests_postingsReport = [ "postingsReport" ~: do -- with the query specified explicitly let (query, journal) `gives` n = (length $ snd $ postingsReport defreportopts query journal) `is` n (Any, nulljournal) `gives` 0 (Any, samplejournal) `gives` 11 -- register --depth just clips account names (Depth 2, samplejournal) `gives` 11 (And [Depth 1, Status True, Acct "expenses"], samplejournal) `gives` 2 (And [And [Depth 1, Status True], Acct "expenses"], samplejournal) `gives` 2 -- with query and/or command-line options assertEqual "" 11 (length $ snd $ postingsReport defreportopts Any samplejournal) assertEqual "" 9 (length $ snd $ postingsReport defreportopts{monthly_=True} Any samplejournal) assertEqual "" 19 (length $ snd $ postingsReport defreportopts{monthly_=True} (Empty True) samplejournal) assertEqual "" 4 (length $ snd $ postingsReport defreportopts (Acct "assets:bank:checking") samplejournal) -- (defreportopts, And [Acct "a a", Acct "'b"], samplejournal2) `gives` 0 -- [(Just (parsedate "2008-01-01","income"),assets:bank:checking $1,$1) -- ,(Nothing,income:salary $-1,0) -- ,(Just (2008-06-01,"gift"),assets:bank:checking $1,$1) -- ,(Nothing,income:gifts $-1,0) -- ,(Just (2008-06-02,"save"),assets:bank:saving $1,$1) -- ,(Nothing,assets:bank:checking $-1,0) -- ,(Just (2008-06-03,"eat & shop"),expenses:food $1,$1) -- ,(Nothing,expenses:supplies $1,$2) -- ,(Nothing,assets:cash $-2,0) -- ,(Just (2008-12-31,"pay off"),liabilities:debts $1,$1) -- ,(Nothing,assets:bank:checking $-1,0) -- ] {- let opts = defreportopts (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines ["2008/01/01 income assets:bank:checking $1 $1" ," income:salary $-1 0" ,"2008/06/01 gift assets:bank:checking $1 $1" ," income:gifts $-1 0" ,"2008/06/02 save assets:bank:saving $1 $1" ," assets:bank:checking $-1 0" ,"2008/06/03 eat & shop expenses:food $1 $1" ," expenses:supplies $1 $2" ," assets:cash $-2 0" ,"2008/12/31 pay off liabilities:debts $1 $1" ," assets:bank:checking $-1 0" ] ,"postings report with cleared option" ~: do let opts = defreportopts{cleared_=True} j <- readJournal' sample_journal_str (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines ["2008/06/03 eat & shop expenses:food $1 $1" ," expenses:supplies $1 $2" ," assets:cash $-2 0" ,"2008/12/31 pay off liabilities:debts $1 $1" ," assets:bank:checking $-1 0" ] ,"postings report with uncleared option" ~: do let opts = defreportopts{uncleared_=True} j <- readJournal' sample_journal_str (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines ["2008/01/01 income assets:bank:checking $1 $1" ," income:salary $-1 0" ,"2008/06/01 gift assets:bank:checking $1 $1" ," income:gifts $-1 0" ,"2008/06/02 save assets:bank:saving $1 $1" ," assets:bank:checking $-1 0" ] ,"postings report sorts by date" ~: do j <- readJournal' $ unlines ["2008/02/02 a" ," b 1" ," c" ,"" ,"2008/01/01 d" ," e 1" ," f" ] let opts = defreportopts registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` ["2008/01/01","2008/02/02"] ,"postings report with account pattern" ~: do j <- samplejournal let opts = defreportopts{patterns_=["cash"]} (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines ["2008/06/03 eat & shop assets:cash $-2 $-2" ] ,"postings report with account pattern, case insensitive" ~: do j <- samplejournal let opts = defreportopts{patterns_=["cAsH"]} (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines ["2008/06/03 eat & shop assets:cash $-2 $-2" ] ,"postings report with display expression" ~: do j <- samplejournal let gives displayexpr = (registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is`) where opts = defreportopts{display_=Just displayexpr} "d<[2008/6/2]" `gives` ["2008/01/01","2008/06/01"] "d<=[2008/6/2]" `gives` ["2008/01/01","2008/06/01","2008/06/02"] "d=[2008/6/2]" `gives` ["2008/06/02"] "d>=[2008/6/2]" `gives` ["2008/06/02","2008/06/03","2008/12/31"] "d>[2008/6/2]" `gives` ["2008/06/03","2008/12/31"] ,"postings report with period expression" ~: do j <- samplejournal let periodexpr `gives` dates = do j' <- samplejournal registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j') `is` dates where opts = defreportopts{period_=maybePeriod date1 periodexpr} "" `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"] "2008" `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"] "2007" `gives` [] "june" `gives` ["2008/06/01","2008/06/02","2008/06/03"] "monthly" `gives` ["2008/01/01","2008/06/01","2008/12/01"] "quarterly" `gives` ["2008/01/01","2008/04/01","2008/10/01"] let opts = defreportopts{period_=maybePeriod date1 "yearly"} (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines ["2008/01/01 - 2008/12/31 assets:bank:saving $1 $1" ," assets:cash $-2 $-1" ," expenses:food $1 0" ," expenses:supplies $1 $1" ," income:gifts $-1 0" ," income:salary $-1 $-1" ," liabilities:debts $1 0" ] let opts = defreportopts{period_=maybePeriod date1 "quarterly"} registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` ["2008/01/01","2008/04/01","2008/10/01"] let opts = defreportopts{period_=maybePeriod date1 "quarterly",empty_=True} registerdates (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` ["2008/01/01","2008/04/01","2008/07/01","2008/10/01"] ] , "postings report with depth arg" ~: do j <- samplejournal let opts = defreportopts{depth_=Just 2} (postingsReportAsText opts $ postingsReport opts (queryFromOpts date1 opts) j) `is` unlines ["2008/01/01 income assets:bank $1 $1" ," income:salary $-1 0" ,"2008/06/01 gift assets:bank $1 $1" ," income:gifts $-1 0" ,"2008/06/02 save assets:bank $1 $1" ," assets:bank $-1 0" ,"2008/06/03 eat & shop expenses:food $1 $1" ," expenses:supplies $1 $2" ," assets:cash $-2 0" ,"2008/12/31 pay off liabilities:debts $1 $1" ," assets:bank $-1 0" ] -} ] tests_balanceReport = let (opts,journal) `gives` r = do let (eitems, etotal) = r (aitems, atotal) = balanceReport opts (queryFromOpts nulldate opts) journal assertEqual "items" eitems aitems -- assertEqual "" (length eitems) (length aitems) -- mapM (\(e,a) -> assertEqual "" e a) $ zip eitems aitems assertEqual "total" etotal atotal in [ "balanceReport with no args on null journal" ~: do (defreportopts, nulljournal) `gives` ([], Mixed [nullamt]) ,"balanceReport with no args on sample journal" ~: do (defreportopts, samplejournal) `gives` ([ ("assets","assets",0, mamountp' "$-1.00") ,("assets:bank:saving","bank:saving",1, mamountp' "$1.00") ,("assets:cash","cash",1, mamountp' "$-2.00") ,("expenses","expenses",0, mamountp' "$2.00") ,("expenses:food","food",1, mamountp' "$1.00") ,("expenses:supplies","supplies",1, mamountp' "$1.00") ,("income","income",0, mamountp' "$-2.00") ,("income:gifts","gifts",1, mamountp' "$-1.00") ,("income:salary","salary",1, mamountp' "$-1.00") ,("liabilities:debts","liabilities:debts",0, mamountp' "$1.00") ], Mixed [nullamt]) ,"balanceReport with --depth=N" ~: do (defreportopts{depth_=Just 1}, samplejournal) `gives` ([ ("assets", "assets", 0, mamountp' "$-1.00") ,("expenses", "expenses", 0, mamountp' "$2.00") ,("income", "income", 0, mamountp' "$-2.00") ,("liabilities", "liabilities", 0, mamountp' "$1.00") ], Mixed [nullamt]) ,"balanceReport with depth:N" ~: do (defreportopts{query_="depth:1"}, samplejournal) `gives` ([ ("assets", "assets", 0, mamountp' "$-1.00") ,("expenses", "expenses", 0, mamountp' "$2.00") ,("income", "income", 0, mamountp' "$-2.00") ,("liabilities", "liabilities", 0, mamountp' "$1.00") ], Mixed [nullamt]) ,"balanceReport with a date or secondary date span" ~: do (defreportopts{query_="date:'in 2009'"}, samplejournal2) `gives` ([], Mixed [nullamt]) (defreportopts{query_="edate:'in 2009'"}, samplejournal2) `gives` ([ ("assets:bank:checking","assets:bank:checking",0,mamountp' "$1.00") ,("income:salary","income:salary",0,mamountp' "$-1.00") ], Mixed [nullamt]) ,"balanceReport with desc:" ~: do (defreportopts{query_="desc:income"}, samplejournal) `gives` ([ ("assets:bank:checking","assets:bank:checking",0,mamountp' "$1.00") ,("income:salary","income:salary",0, mamountp' "$-1.00") ], Mixed [nullamt]) ,"balanceReport with not:desc:" ~: do (defreportopts{query_="not:desc:income"}, samplejournal) `gives` ([ ("assets","assets",0, mamountp' "$-2.00") ,("assets:bank","bank",1, Mixed [nullamt]) ,("assets:bank:checking","checking",2,mamountp' "$-1.00") ,("assets:bank:saving","saving",2, mamountp' "$1.00") ,("assets:cash","cash",1, mamountp' "$-2.00") ,("expenses","expenses",0, mamountp' "$2.00") ,("expenses:food","food",1, mamountp' "$1.00") ,("expenses:supplies","supplies",1, mamountp' "$1.00") ,("income:gifts","income:gifts",0, mamountp' "$-1.00") ,("liabilities:debts","liabilities:debts",0, mamountp' "$1.00") ], Mixed [nullamt]) {- ,"accounts report with account pattern o" ~: defreportopts{patterns_=["o"]} `gives` [" $1 expenses:food" ," $-2 income" ," $-1 gifts" ," $-1 salary" ,"--------------------" ," $-1" ] ,"accounts report with account pattern o and --depth 1" ~: defreportopts{patterns_=["o"],depth_=Just 1} `gives` [" $1 expenses" ," $-2 income" ,"--------------------" ," $-1" ] ,"accounts report with account pattern a" ~: defreportopts{patterns_=["a"]} `gives` [" $-1 assets" ," $1 bank:saving" ," $-2 cash" ," $-1 income:salary" ," $1 liabilities:debts" ,"--------------------" ," $-1" ] ,"accounts report with account pattern e" ~: defreportopts{patterns_=["e"]} `gives` [" $-1 assets" ," $1 bank:saving" ," $-2 cash" ," $2 expenses" ," $1 food" ," $1 supplies" ," $-2 income" ," $-1 gifts" ," $-1 salary" ," $1 liabilities:debts" ,"--------------------" ," 0" ] ,"accounts report with unmatched parent of two matched subaccounts" ~: defreportopts{patterns_=["cash","saving"]} `gives` [" $-1 assets" ," $1 bank:saving" ," $-2 cash" ,"--------------------" ," $-1" ] ,"accounts report with multi-part account name" ~: defreportopts{patterns_=["expenses:food"]} `gives` [" $1 expenses:food" ,"--------------------" ," $1" ] ,"accounts report with negative account pattern" ~: defreportopts{patterns_=["not:assets"]} `gives` [" $2 expenses" ," $1 food" ," $1 supplies" ," $-2 income" ," $-1 gifts" ," $-1 salary" ," $1 liabilities:debts" ,"--------------------" ," $1" ] ,"accounts report negative account pattern always matches full name" ~: defreportopts{patterns_=["not:e"]} `gives` ["--------------------" ," 0" ] ,"accounts report negative patterns affect totals" ~: defreportopts{patterns_=["expenses","not:food"]} `gives` [" $1 expenses:supplies" ,"--------------------" ," $1" ] ,"accounts report with -E shows zero-balance accounts" ~: defreportopts{patterns_=["assets"],empty_=True} `gives` [" $-1 assets" ," $1 bank" ," 0 checking" ," $1 saving" ," $-2 cash" ,"--------------------" ," $-1" ] ,"accounts report with cost basis" ~: do j <- (readJournal Nothing Nothing Nothing $ unlines ["" ,"2008/1/1 test " ," a:b 10h @ $50" ," c:d " ]) >>= either error' return let j' = journalCanonicaliseAmounts $ journalConvertAmountsToCost j -- enable cost basis adjustment balanceReportAsText defreportopts (balanceReport defreportopts Any j') `is` [" $500 a:b" ," $-500 c:d" ,"--------------------" ," 0" ] -} ] Right samplejournal2 = journalBalanceTransactions $ nulljournal {jtxns = [ txnTieKnot $ Transaction { tdate=parsedate "2008/01/01", tdate2=Just $ parsedate "2009/01/01", tstatus=False, tcode="", tdescription="income", tcomment="", ttags=[], tpostings= [posting {paccount="assets:bank:checking", pamount=Mixed [usd 1]} ,posting {paccount="income:salary", pamount=missingmixedamt} ], tpreceding_comment_lines="" } ] } -- tests_isInterestingIndented = [ -- "isInterestingIndented" ~: do -- let (opts, journal, acctname) `gives` r = isInterestingIndented opts l acctname `is` r -- where l = ledgerFromJournal (queryFromOpts nulldate opts) journal -- (defreportopts, samplejournal, "expenses") `gives` True -- ] tests_Hledger_Reports :: Test tests_Hledger_Reports = TestList $ tests_queryFromOpts ++ tests_queryOptsFromOpts ++ tests_entriesReport ++ tests_summarisePostingsByInterval ++ tests_postingsReport -- ++ tests_isInterestingIndented ++ tests_balanceReport ++ [ -- ,"summarisePostingsInDateSpan" ~: do -- let gives (b,e,depth,showempty,ps) = -- (summarisePostingsInDateSpan (mkdatespan b e) depth showempty ps `is`) -- let ps = -- [ -- nullposting{lpdescription="desc",lpaccount="expenses:food:groceries",lpamount=Mixed [usd 1]} -- ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining", lpamount=Mixed [usd 2]} -- ,nullposting{lpdescription="desc",lpaccount="expenses:food", lpamount=Mixed [usd 4]} -- ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining", lpamount=Mixed [usd 8]} -- ] -- ("2008/01/01","2009/01/01",0,9999,False,[]) `gives` -- [] -- ("2008/01/01","2009/01/01",0,9999,True,[]) `gives` -- [ -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31"} -- ] -- ("2008/01/01","2009/01/01",0,9999,False,ts) `gives` -- [ -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food", lpamount=Mixed [usd 4]} -- ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:dining", lpamount=Mixed [usd 10]} -- ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:groceries",lpamount=Mixed [usd 1]} -- ] -- ("2008/01/01","2009/01/01",0,2,False,ts) `gives` -- [ -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food",lpamount=Mixed [usd 15]} -- ] -- ("2008/01/01","2009/01/01",0,1,False,ts) `gives` -- [ -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses",lpamount=Mixed [usd 15]} -- ] -- ("2008/01/01","2009/01/01",0,0,False,ts) `gives` -- [ -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="",lpamount=Mixed [usd 15]} -- ] ] hledger-lib-0.22/Hledger/Read/0000755000000000000000000000000012252750510014225 5ustar0000000000000000hledger-lib-0.22/Hledger/Read/JournalReader.hs0000644000000000000000000011142112252750510017316 0ustar0000000000000000-- {-# OPTIONS_GHC -F -pgmF htfpp #-} {-# LANGUAGE CPP, RecordWildCards, NoMonoLocalBinds #-} {-| A reader for hledger's journal file format (). hledger's journal format is a compatible subset of c++ ledger's (), so this reader should handle many ledger files as well. Example: @ 2012\/3\/24 gift expenses:gifts $10 assets:cash @ -} module Hledger.Read.JournalReader ( -- * Reader reader, -- * Parsers used elsewhere parseJournalWith, getParentAccount, journal, directive, defaultyeardirective, historicalpricedirective, datetime, code, accountname, amountp, amountp', mamountp', emptyline #ifdef TESTS -- * Tests -- disabled by default, HTF not available on windows ,htf_thisModulesTests ,htf_Hledger_Read_JournalReader_importedTests #endif ) where import qualified Control.Exception as C import Control.Monad import Control.Monad.Error import Data.Char (isNumber) import Data.List import Data.List.Split (wordsBy) import Data.Maybe import Data.Time.Calendar import Data.Time.LocalTime import Safe (headDef, lastDef) #ifdef TESTS import Test.Framework import Text.Parsec.Error #endif import Text.ParserCombinators.Parsec hiding (parse) import Text.Printf import System.FilePath import System.Time (getClockTime) import Hledger.Data import Hledger.Utils import Prelude hiding (readFile) -- standard reader exports reader :: Reader reader = Reader format detect parse format :: String format = "journal" -- | Does the given file path and data provide hledger's journal file format ? detect :: FilePath -> String -> Bool detect f _ = takeExtension f `elem` ['.':format, ".j"] -- | Parse and post-process a "Journal" from hledger's journal file -- format, or give an error. parse :: Maybe FilePath -> FilePath -> String -> ErrorT String IO Journal parse _ = -- trace ("running "++format++" reader") . parseJournalWith journal -- parsing utils -- | Flatten a list of JournalUpdate's into a single equivalent one. combineJournalUpdates :: [JournalUpdate] -> JournalUpdate combineJournalUpdates us = liftM (foldl' (.) id) $ sequence us -- | Given a JournalUpdate-generating parsec parser, file path and data string, -- parse and post-process a Journal so that it's ready to use, or give an error. parseJournalWith :: (GenParser Char JournalContext (JournalUpdate,JournalContext)) -> FilePath -> String -> ErrorT String IO Journal parseJournalWith p f s = do tc <- liftIO getClockTime tl <- liftIO getCurrentLocalTime y <- liftIO getCurrentYear case runParser p nullctx{ctxYear=Just y} f s of Right (updates,ctx) -> do j <- updates `ap` return nulljournal case journalFinalise tc tl f s ctx j of Right j' -> return j' Left estr -> throwError estr Left e -> throwError $ show e setYear :: Integer -> GenParser tok JournalContext () setYear y = updateState (\ctx -> ctx{ctxYear=Just y}) getYear :: GenParser tok JournalContext (Maybe Integer) getYear = liftM ctxYear getState setCommodityAndStyle :: (Commodity,AmountStyle) -> GenParser tok JournalContext () setCommodityAndStyle cs = updateState (\ctx -> ctx{ctxCommodityAndStyle=Just cs}) getCommodityAndStyle :: GenParser tok JournalContext (Maybe (Commodity,AmountStyle)) getCommodityAndStyle = ctxCommodityAndStyle `fmap` getState pushParentAccount :: String -> GenParser tok JournalContext () pushParentAccount parent = updateState addParentAccount where addParentAccount ctx0 = ctx0 { ctxAccount = parent : ctxAccount ctx0 } popParentAccount :: GenParser tok JournalContext () popParentAccount = do ctx0 <- getState case ctxAccount ctx0 of [] -> unexpected "End of account block with no beginning" (_:rest) -> setState $ ctx0 { ctxAccount = rest } getParentAccount :: GenParser tok JournalContext String getParentAccount = liftM (concatAccountNames . reverse . ctxAccount) getState addAccountAlias :: (AccountName,AccountName) -> GenParser tok JournalContext () addAccountAlias a = updateState (\(ctx@Ctx{..}) -> ctx{ctxAliases=a:ctxAliases}) getAccountAliases :: GenParser tok JournalContext [(AccountName,AccountName)] getAccountAliases = liftM ctxAliases getState clearAccountAliases :: GenParser tok JournalContext () clearAccountAliases = updateState (\(ctx@Ctx{..}) -> ctx{ctxAliases=[]}) -- parsers -- | Top-level journal parser. Returns a single composite, I/O performing, -- error-raising "JournalUpdate" (and final "JournalContext") which can be -- applied to an empty journal to get the final result. journal :: GenParser Char JournalContext (JournalUpdate,JournalContext) journal = do journalupdates <- many journalItem eof finalctx <- getState return $ (combineJournalUpdates journalupdates, finalctx) where -- As all journal line types can be distinguished by the first -- character, excepting transactions versus empty (blank or -- comment-only) lines, can use choice w/o try journalItem = choice [ directive , liftM (return . addTransaction) transaction , liftM (return . addModifierTransaction) modifiertransaction , liftM (return . addPeriodicTransaction) periodictransaction , liftM (return . addHistoricalPrice) historicalpricedirective , emptyline >> return (return id) ] "journal transaction or directive" -- cf http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives directive :: GenParser Char JournalContext JournalUpdate directive = do optional $ char '!' choice' [ includedirective ,aliasdirective ,endaliasesdirective ,accountdirective ,enddirective ,tagdirective ,endtagdirective ,defaultyeardirective ,defaultcommoditydirective ,commodityconversiondirective ,ignoredpricecommoditydirective ] "directive" includedirective :: GenParser Char JournalContext JournalUpdate includedirective = do string "include" many1 spacenonewline filename <- restofline outerState <- getState outerPos <- getPosition let curdir = takeDirectory (sourceName outerPos) return $ do filepath <- expandPath curdir filename txt <- readFileOrError outerPos filepath let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n" case runParser journal outerState filepath txt of Right (ju,_) -> combineJournalUpdates [return $ journalAddFile (filepath,txt), ju] `catchError` (throwError . (inIncluded ++)) Left err -> throwError $ inIncluded ++ show err where readFileOrError pos fp = ErrorT $ liftM Right (readFile' fp) `C.catch` \e -> return $ Left $ printf "%s reading %s:\n%s" (show pos) fp (show (e::C.IOException)) journalAddFile :: (FilePath,String) -> Journal -> Journal journalAddFile f j@Journal{files=fs} = j{files=fs++[f]} -- XXX currently called in reverse order of includes, I can't see why accountdirective :: GenParser Char JournalContext JournalUpdate accountdirective = do string "account" many1 spacenonewline parent <- accountname newline pushParentAccount parent return $ return id enddirective :: GenParser Char JournalContext JournalUpdate enddirective = do string "end" popParentAccount return (return id) aliasdirective :: GenParser Char JournalContext JournalUpdate aliasdirective = do string "alias" many1 spacenonewline orig <- many1 $ noneOf "=" char '=' alias <- restofline addAccountAlias (accountNameWithoutPostingType $ strip orig ,accountNameWithoutPostingType $ strip alias) return $ return id endaliasesdirective :: GenParser Char JournalContext JournalUpdate endaliasesdirective = do string "end aliases" clearAccountAliases return (return id) tagdirective :: GenParser Char JournalContext JournalUpdate tagdirective = do string "tag" "tag directive" many1 spacenonewline _ <- many1 nonspace restofline return $ return id endtagdirective :: GenParser Char JournalContext JournalUpdate endtagdirective = do (string "end tag" <|> string "pop") "end tag or pop directive" restofline return $ return id defaultyeardirective :: GenParser Char JournalContext JournalUpdate defaultyeardirective = do char 'Y' "default year" many spacenonewline y <- many1 digit let y' = read y failIfInvalidYear y setYear y' return $ return id defaultcommoditydirective :: GenParser Char JournalContext JournalUpdate defaultcommoditydirective = do char 'D' "default commodity" many1 spacenonewline Amount{..} <- amountp setCommodityAndStyle (acommodity, astyle) restofline return $ return id historicalpricedirective :: GenParser Char JournalContext HistoricalPrice historicalpricedirective = do char 'P' "historical price" many spacenonewline date <- try (do {LocalTime d _ <- datetime; return d}) <|> date -- a time is ignored many1 spacenonewline symbol <- commoditysymbol many spacenonewline price <- amountp restofline return $ HistoricalPrice date symbol price ignoredpricecommoditydirective :: GenParser Char JournalContext JournalUpdate ignoredpricecommoditydirective = do char 'N' "ignored-price commodity" many1 spacenonewline commoditysymbol restofline return $ return id commodityconversiondirective :: GenParser Char JournalContext JournalUpdate commodityconversiondirective = do char 'C' "commodity conversion" many1 spacenonewline amountp many spacenonewline char '=' many spacenonewline amountp restofline return $ return id modifiertransaction :: GenParser Char JournalContext ModifierTransaction modifiertransaction = do char '=' "modifier transaction" many spacenonewline valueexpr <- restofline postings <- postings return $ ModifierTransaction valueexpr postings periodictransaction :: GenParser Char JournalContext PeriodicTransaction periodictransaction = do char '~' "periodic transaction" many spacenonewline periodexpr <- restofline postings <- postings return $ PeriodicTransaction periodexpr postings -- | Parse a (possibly unbalanced) transaction. transaction :: GenParser Char JournalContext Transaction transaction = do -- ptrace "transaction" date <- date "transaction" edate <- optionMaybe (secondarydate date) "secondary date" status <- status "cleared flag" code <- code "transaction code" description <- descriptionp >>= return . strip comment <- try followingcomment <|> (newline >> return "") let tags = tagsInComment comment postings <- postings return $ txnTieKnot $ Transaction date edate status code description comment tags postings "" descriptionp = many (noneOf ";\n") #ifdef TESTS test_transaction = do let s `gives` t = do let p = parseWithCtx nullctx transaction s assertBool $ isRight p let Right t2 = p -- same f = assertEqual (f t) (f t2) assertEqual (tdate t) (tdate t2) assertEqual (tdate2 t) (tdate2 t2) assertEqual (tstatus t) (tstatus t2) assertEqual (tcode t) (tcode t2) assertEqual (tdescription t) (tdescription t2) assertEqual (tcomment t) (tcomment t2) assertEqual (ttags t) (ttags t2) assertEqual (tpreceding_comment_lines t) (tpreceding_comment_lines t2) assertEqual (show $ tpostings t) (show $ tpostings t2) -- "0000/01/01\n\n" `gives` nulltransaction unlines [ "2012/05/14=2012/05/15 (code) desc ; tcomment1", " ; tcomment2", " ; ttag1: val1", " * a $1.00 ; pcomment1", " ; pcomment2", " ; ptag1: val1", " ; ptag2: val2" ] `gives` nulltransaction{ tdate=parsedate "2012/05/14", tdate2=Just $ parsedate "2012/05/15", tstatus=False, tcode="code", tdescription="desc", tcomment=" tcomment1\n tcomment2\n ttag1: val1\n", ttags=[("ttag1","val1")], tpostings=[ nullposting{ pstatus=True, paccount="a", pamount=Mixed [usd 1], pcomment=" pcomment1\n pcomment2\n ptag1: val1\n ptag2: val2\n", ptype=RegularPosting, ptags=[("ptag1","val1"),("ptag2","val2")], ptransaction=Nothing } ], tpreceding_comment_lines="" } assertRight $ parseWithCtx nullctx transaction $ unlines ["2007/01/28 coopportunity" ," expenses:food:groceries $47.18" ," assets:checking $-47.18" ,"" ] -- transaction should not parse just a date assertLeft $ parseWithCtx nullctx transaction "2009/1/1\n" -- transaction should not parse just a date and description assertLeft $ parseWithCtx nullctx transaction "2009/1/1 a\n" -- transaction should not parse a following comment as part of the description let p = parseWithCtx nullctx transaction "2009/1/1 a ;comment\n b 1\n" assertRight p assertEqual "a" (let Right p' = p in tdescription p') -- parse transaction with following whitespace line assertRight $ parseWithCtx nullctx transaction $ unlines ["2012/1/1" ," a 1" ," b" ," " ] let p = parseWithCtx nullctx transaction $ unlines ["2009/1/1 x ; transaction comment" ," a 1 ; posting 1 comment" ," ; posting 1 comment 2" ," b" ," ; posting 2 comment" ] assertRight p assertEqual 2 (let Right t = p in length $ tpostings t) #endif -- | Parse a date in YYYY/MM/DD format. Fewer digits are allowed. The year -- may be omitted if a default year has already been set. date :: GenParser Char JournalContext Day date = do -- hacky: try to ensure precise errors for invalid dates -- XXX reported error position is not too good -- pos <- getPosition datestr <- many1 $ choice' [digit, datesepchar] let dateparts = wordsBy (`elem` datesepchars) datestr currentyear <- getYear [y,m,d] <- case (dateparts,currentyear) of ([m,d],Just y) -> return [show y,m,d] ([_,_],Nothing) -> fail $ "partial date "++datestr++" found, but the current year is unknown" ([y,m,d],_) -> return [y,m,d] _ -> fail $ "bad date: " ++ datestr let maybedate = fromGregorianValid (read y) (read m) (read d) case maybedate of Nothing -> fail $ "bad date: " ++ datestr Just date -> return date "full or partial date" -- | Parse a date and time in YYYY/MM/DD HH:MM[:SS][+-ZZZZ] format. Any -- timezone will be ignored; the time is treated as local time. Fewer -- digits are allowed, except in the timezone. The year may be omitted if -- a default year has already been set. datetime :: GenParser Char JournalContext LocalTime datetime = do day <- date many1 spacenonewline h <- many1 digit let h' = read h guard $ h' >= 0 && h' <= 23 char ':' m <- many1 digit let m' = read m guard $ m' >= 0 && m' <= 59 s <- optionMaybe $ char ':' >> many1 digit let s' = case s of Just sstr -> read sstr Nothing -> 0 guard $ s' >= 0 && s' <= 59 {- tz <- -} optionMaybe $ do plusminus <- oneOf "-+" d1 <- digit d2 <- digit d3 <- digit d4 <- digit return $ plusminus:d1:d2:d3:d4:"" -- ltz <- liftIO $ getCurrentTimeZone -- let tz' = maybe ltz (fromMaybe ltz . parseTime defaultTimeLocale "%z") tz -- return $ localTimeToUTC tz' $ LocalTime day $ TimeOfDay h' m' (fromIntegral s') return $ LocalTime day $ TimeOfDay h' m' (fromIntegral s') secondarydate :: Day -> GenParser Char JournalContext Day secondarydate primarydate = do char '=' -- kludgy way to use primary date for default year let withDefaultYear d p = do y <- getYear let (y',_,_) = toGregorian d in setYear y' r <- p when (isJust y) $ setYear $ fromJust y return r edate <- withDefaultYear primarydate date return edate status :: GenParser Char JournalContext Bool status = try (do { many spacenonewline; (char '*' <|> char '!') "status"; return True } ) <|> return False code :: GenParser Char JournalContext String code = try (do { many1 spacenonewline; char '(' "code"; code <- anyChar `manyTill` char ')'; return code } ) <|> return "" -- Parse the following whitespace-beginning lines as postings, posting tags, and/or comments. postings :: GenParser Char JournalContext [Posting] postings = many1 (try postingp) "postings" -- linebeginningwithspaces :: GenParser Char JournalContext String -- linebeginningwithspaces = do -- sp <- many1 spacenonewline -- c <- nonspace -- cs <- restofline -- return $ sp ++ (c:cs) ++ "\n" postingp :: GenParser Char JournalContext Posting postingp = do many1 spacenonewline status <- status many spacenonewline account <- modifiedaccountname let (ptype, account') = (accountNamePostingType account, unbracket account) amount <- spaceandamountormissing massertion <- balanceassertion _ <- fixedlotprice many spacenonewline ctx <- getState comment <- try followingcomment <|> (newline >> return "") let tags = tagsInComment comment -- oh boy d <- maybe (return Nothing) (either (fail.show) (return.Just)) (parseWithCtx ctx date `fmap` dateValueFromTags tags) d2 <- maybe (return Nothing) (either (fail.show) (return.Just)) (parseWithCtx ctx date `fmap` date2ValueFromTags tags) return posting{pdate=d, pdate2=d2, pstatus=status, paccount=account', pamount=amount, pcomment=comment, ptype=ptype, ptags=tags, pbalanceassertion=massertion} #ifdef TESTS test_postingp = do let s `gives` ep = do let parse = parseWithCtx nullctx postingp s assertBool -- "postingp parser" $ isRight parse let Right ap = parse same f = assertEqual (f ep) (f ap) same pdate same pstatus same paccount same pamount same pcomment same ptype same ptags same ptransaction " expenses:food:dining $10.00 ; a: a a \n ; b: b b \n" `gives` posting{paccount="expenses:food:dining", pamount=Mixed [usd 10], pcomment=" a: a a \n b: b b \n", ptags=[("a","a a"), ("b","b b")]} " a 1 ; [2012/11/28]\n" `gives` ("a" `post` num 1){pcomment=" [2012/11/28]\n" ,ptags=[("date","2012/11/28")] ,pdate=parsedateM "2012/11/28"} " a 1 ; a:a, [=2012/11/28]\n" `gives` ("a" `post` num 1){pcomment=" a:a, [=2012/11/28]\n" ,ptags=[("a","a"), ("date2","2012/11/28")] ,pdate=Nothing} " a 1 ; a:a\n ; [2012/11/28=2012/11/29],b:b\n" `gives` ("a" `post` num 1){pcomment=" a:a\n [2012/11/28=2012/11/29],b:b\n" ,ptags=[("a","a"), ("date","2012/11/28"), ("date2","2012/11/29"), ("b","b")] ,pdate=parsedateM "2012/11/28"} assertBool -- "postingp parses a quoted commodity with numbers" (isRight $ parseWithCtx nullctx postingp " a 1 \"DE123\"\n") -- ,"postingp parses balance assertions and fixed lot prices" ~: do assertBool (isRight $ parseWithCtx nullctx postingp " a 1 \"DE123\" =$1 { =2.2 EUR} \n") -- let parse = parseWithCtx nullctx postingp " a\n ;next-line comment\n" -- assertRight parse -- let Right p = parse -- assertEqual "next-line comment\n" (pcomment p) -- assertEqual (Just nullmixedamt) (pbalanceassertion p) #endif -- | Parse an account name, then apply any parent account prefix and/or account aliases currently in effect. modifiedaccountname :: GenParser Char JournalContext AccountName modifiedaccountname = do a <- accountname prefix <- getParentAccount let prefixed = prefix `joinAccountNames` a aliases <- getAccountAliases return $ accountNameApplyAliases aliases prefixed -- | Parse an account name. Account names may have single spaces inside -- them, and are terminated by two or more spaces. They should have one or -- more components of at least one character, separated by the account -- separator char. accountname :: GenParser Char st AccountName accountname = do a <- many1 (nonspace <|> singlespace) let a' = striptrailingspace a when (accountNameFromComponents (accountNameComponents a') /= a') (fail $ "accountname seems ill-formed: "++a') return a' where singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}}) -- couldn't avoid consuming a final space sometimes, harmless striptrailingspace s = if last s == ' ' then init s else s -- accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace -- "account name character (non-bracket, non-parenthesis, non-whitespace)" -- | Parse whitespace then an amount, with an optional left or right -- currency symbol and optional price, or return the special -- "missing" marker amount. spaceandamountormissing :: GenParser Char JournalContext MixedAmount spaceandamountormissing = try (do many1 spacenonewline (Mixed . (:[])) `fmap` amountp <|> return missingmixedamt ) <|> return missingmixedamt #ifdef TESTS assertParseEqual' :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion assertParseEqual' parse expected = either (assertFailure.show) (`is'` expected) parse is' :: (Eq a, Show a) => a -> a -> Assertion a `is'` e = assertEqual e a test_spaceandamountormissing = do assertParseEqual' (parseWithCtx nullctx spaceandamountormissing " $47.18") (Mixed [usd 47.18]) assertParseEqual' (parseWithCtx nullctx spaceandamountormissing "$47.18") missingmixedamt assertParseEqual' (parseWithCtx nullctx spaceandamountormissing " ") missingmixedamt assertParseEqual' (parseWithCtx nullctx spaceandamountormissing "") missingmixedamt #endif -- | Parse a single-commodity amount, with optional symbol on the left or -- right, optional unit or total price, and optional (ignored) -- ledger-style balance assertion or fixed lot price declaration. amountp :: GenParser Char JournalContext Amount amountp = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount #ifdef TESTS test_amountp = do assertParseEqual' (parseWithCtx nullctx amountp "$47.18") (usd 47.18) assertParseEqual' (parseWithCtx nullctx amountp "$1.") (usd 1 `withPrecision` 0) -- ,"amount with unit price" ~: do assertParseEqual' (parseWithCtx nullctx amountp "$10 @ €0.5") (usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1)) -- ,"amount with total price" ~: do assertParseEqual' (parseWithCtx nullctx amountp "$10 @@ €5") (usd 10 `withPrecision` 0 @@ (eur 5 `withPrecision` 0)) #endif -- | Parse an amount from a string, or get an error. amountp' :: String -> Amount amountp' s = either (error' . show) id $ parseWithCtx nullctx amountp s -- | Parse a mixed amount from a string, or get an error. mamountp' :: String -> MixedAmount mamountp' = mixed . amountp' leftsymbolamount :: GenParser Char JournalContext Amount leftsymbolamount = do sign <- optionMaybe $ string "-" let applysign = if isJust sign then negate else id c <- commoditysymbol sp <- many spacenonewline (q,prec,dec,sep,seppos) <- number let s = amountstyle{ascommodityside=L, ascommodityspaced=not $ null sp, asdecimalpoint=dec, asprecision=prec, asseparator=sep, asseparatorpositions=seppos} p <- priceamount return $ applysign $ Amount c q p s "left-symbol amount" rightsymbolamount :: GenParser Char JournalContext Amount rightsymbolamount = do (q,prec,dec,sep,seppos) <- number sp <- many spacenonewline c <- commoditysymbol p <- priceamount let s = amountstyle{ascommodityside=R, ascommodityspaced=not $ null sp, asdecimalpoint=dec, asprecision=prec, asseparator=sep, asseparatorpositions=seppos} return $ Amount c q p s "right-symbol amount" nosymbolamount :: GenParser Char JournalContext Amount nosymbolamount = do (q,prec,dec,sep,seppos) <- number p <- priceamount defcs <- getCommodityAndStyle let (c,s) = case defcs of Just (c',s') -> (c',s') Nothing -> ("", amountstyle{asdecimalpoint=dec, asprecision=prec, asseparator=sep, asseparatorpositions=seppos}) return $ Amount c q p s "no-symbol amount" commoditysymbol :: GenParser Char JournalContext String commoditysymbol = (quotedcommoditysymbol <|> simplecommoditysymbol) "commodity symbol" quotedcommoditysymbol :: GenParser Char JournalContext String quotedcommoditysymbol = do char '"' s <- many1 $ noneOf ";\n\"" char '"' return s simplecommoditysymbol :: GenParser Char JournalContext String simplecommoditysymbol = many1 (noneOf nonsimplecommoditychars) priceamount :: GenParser Char JournalContext Price priceamount = try (do many spacenonewline char '@' try (do char '@' many spacenonewline a <- amountp -- XXX can parse more prices ad infinitum, shouldn't return $ TotalPrice a) <|> (do many spacenonewline a <- amountp -- XXX can parse more prices ad infinitum, shouldn't return $ UnitPrice a)) <|> return NoPrice balanceassertion :: GenParser Char JournalContext (Maybe MixedAmount) balanceassertion = try (do many spacenonewline char '=' many spacenonewline a <- amountp -- XXX should restrict to a simple amount return $ Just $ Mixed [a]) <|> return Nothing -- http://ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices fixedlotprice :: GenParser Char JournalContext (Maybe Amount) fixedlotprice = try (do many spacenonewline char '{' many spacenonewline char '=' many spacenonewline a <- amountp -- XXX should restrict to a simple amount many spacenonewline char '}' return $ Just a) <|> return Nothing -- | Parse a numeric quantity for its value and display attributes. Some -- international number formats (cf -- http://en.wikipedia.org/wiki/Decimal_separator) are accepted: either -- period or comma may be used for the decimal point, and the other of -- these may be used for separating digit groups in the integer part (eg a -- thousands separator). This returns the numeric value, the precision -- (number of digits to the right of the decimal point), the decimal point -- and separator characters (defaulting to . and ,), and the positions of -- separators (counting leftward from the decimal point, the last is -- assumed to repeat). number :: GenParser Char JournalContext (Quantity, Int, Char, Char, [Int]) number = do sign <- optionMaybe $ string "-" parts <- many1 $ choice' [many1 digit, many1 $ char ',', many1 $ char '.'] let numeric = isNumber . headDef '_' (_, puncparts) = partition numeric parts (ok,decimalpoint',separator') = case puncparts of [] -> (True, Nothing, Nothing) -- no punctuation chars [d:""] -> (True, Just d, Nothing) -- just one punctuation char, assume it's a decimal point [_] -> (False, Nothing, Nothing) -- adjacent punctuation chars, not ok _:_:_ -> let (s:ss, d) = (init puncparts, last puncparts) -- two or more punctuation chars in if (any ((/=1).length) puncparts -- adjacent punctuation chars, not ok || any (s/=) ss -- separator chars differ, not ok || head parts == s) -- number begins with a separator char, not ok then (False, Nothing, Nothing) else if s == d then (True, Nothing, Just $ head s) -- just one kind of punctuation, assume separator chars else (True, Just $ head d, Just $ head s) -- separators and a decimal point when (not ok) (fail $ "number seems ill-formed: "++concat parts) let (intparts',fracparts') = span ((/= decimalpoint') . Just . head) parts (intparts, fracpart) = (filter numeric intparts', filter numeric fracparts') separatorpositions = reverse $ map length $ drop 1 intparts int = concat $ "":intparts frac = concat $ "":fracpart precision = length frac int' = if null int then "0" else int frac' = if null frac then "0" else frac sign' = fromMaybe "" sign quantity = read $ sign'++int'++"."++frac' -- this read should never fail (decimalpoint, separator) = case (decimalpoint', separator') of (Just d, Just s) -> (d,s) (Just '.',Nothing) -> ('.',',') (Just ',',Nothing) -> (',','.') (Nothing, Just '.') -> (',','.') (Nothing, Just ',') -> ('.',',') _ -> ('.',',') return (quantity,precision,decimalpoint,separator,separatorpositions) "number" #ifdef TESTS test_number = do let s `is` n = assertParseEqual' (parseWithCtx nullctx number s) n assertFails = assertBool . isLeft . parseWithCtx nullctx number assertFails "" "0" `is` (0, 0, '.', ',', []) "1" `is` (1, 0, '.', ',', []) "1.1" `is` (1.1, 1, '.', ',', []) "1,000.1" `is` (1000.1, 1, '.', ',', [3]) "1.00.000,1" `is` (100000.1, 1, ',', '.', [3,2]) "1,000,000" `is` (1000000, 0, '.', ',', [3,3]) "1." `is` (1, 0, '.', ',', []) "1," `is` (1, 0, ',', '.', []) ".1" `is` (0.1, 1, '.', ',', []) ",1" `is` (0.1, 1, ',', '.', []) assertFails "1,000.000,1" assertFails "1.000,000.1" assertFails "1,000.000.1" assertFails "1,,1" assertFails "1..1" assertFails ".1," assertFails ",1." #endif -- comment parsers emptyline :: GenParser Char JournalContext () emptyline = do many spacenonewline optional $ (char ';' "comment") >> many (noneOf "\n") newline return () followingcomment :: GenParser Char JournalContext String followingcomment = -- ptrace "followingcomment" do samelinecomment <- many spacenonewline >> (try commentline <|> (newline >> return "")) newlinecomments <- many (try (many1 spacenonewline >> commentline)) return $ unlines $ samelinecomment:newlinecomments commentline :: GenParser Char JournalContext String commentline = do -- ptrace "commentline" char ';' many spacenonewline l <- anyChar `manyTill` eolof optional newline return l tagsInComment :: String -> [Tag] tagsInComment c = concatMap tagsInCommentLine $ lines c' where c' = ledgerDateSyntaxToTags c tagsInCommentLine :: String -> [Tag] tagsInCommentLine = catMaybes . map maybetag . map strip . splitAtElement ',' where maybetag s = case parseWithCtx nullctx tag s of Right t -> Just t Left _ -> Nothing tag = do -- ptrace "tag" n <- tagname v <- tagvalue return (n,v) tagname = do -- ptrace "tagname" n <- many1 $ noneOf ": \t" char ':' return n tagvalue = do -- ptrace "tagvalue" v <- anyChar `manyTill` ((char ',' >> return ()) <|> eolof) return $ strip $ reverse $ dropWhile (==',') $ reverse $ strip v ledgerDateSyntaxToTags :: String -> String ledgerDateSyntaxToTags = regexReplaceBy "\\[[-.\\/0-9=]+\\]" replace where replace ('[':s) | lastDef ' ' s == ']' = replace' $ init s replace s = s replace' s | isdate s = datetag s replace' ('=':s) | isdate s = date2tag s replace' s | last s =='=' && isdate (init s) = datetag (init s) replace' s | length ds == 2 && isdate d1 && isdate d1 = datetag d1 ++ date2tag d2 where ds = splitAtElement '=' s d1 = headDef "" ds d2 = lastDef "" ds replace' s = s isdate = isJust . parsedateM datetag s = "date:"++s++", " date2tag s = "date2:"++s++", " #ifdef TESTS test_ledgerDateSyntaxToTags = do assertEqual "date2:2012/11/28, " $ ledgerDateSyntaxToTags "[=2012/11/28]" #endif dateValueFromTags, date2ValueFromTags :: [Tag] -> Maybe String dateValueFromTags ts = maybe Nothing (Just . snd) $ find ((=="date") . fst) ts date2ValueFromTags ts = maybe Nothing (Just . snd) $ find ((=="date2") . fst) ts {- old hunit tests test_Hledger_Read_JournalReader = TestList $ concat [ test_number, test_amountp, test_spaceandamountormissing, test_tagcomment, test_inlinecomment, test_commentlines, test_ledgerDateSyntaxToTags, test_postingp, test_transaction, [ "modifiertransaction" ~: do assertParse (parseWithCtx nullctx modifiertransaction "= (some value expr)\n some:postings 1\n") ,"periodictransaction" ~: do assertParse (parseWithCtx nullctx periodictransaction "~ (some period expr)\n some:postings 1\n") ,"directive" ~: do assertParse (parseWithCtx nullctx directive "!include /some/file.x\n") assertParse (parseWithCtx nullctx directive "account some:account\n") assertParse (parseWithCtx nullctx (directive >> directive) "!account a\nend\n") ,"commentline" ~: do assertParse (parseWithCtx nullctx commentline "; some comment \n") assertParse (parseWithCtx nullctx commentline " \t; x\n") assertParse (parseWithCtx nullctx commentline ";x") ,"date" ~: do assertParse (parseWithCtx nullctx date "2011/1/1") assertParseFailure (parseWithCtx nullctx date "1/1") assertParse (parseWithCtx nullctx{ctxYear=Just 2011} date "1/1") ,"datetime" ~: do let p = do {t <- datetime; eof; return t} bad = assertParseFailure . parseWithCtx nullctx p good = assertParse . parseWithCtx nullctx p bad "2011/1/1" bad "2011/1/1 24:00:00" bad "2011/1/1 00:60:00" bad "2011/1/1 00:00:60" good "2011/1/1 00:00" good "2011/1/1 23:59:59" good "2011/1/1 3:5:7" -- timezone is parsed but ignored let startofday = LocalTime (fromGregorian 2011 1 1) (TimeOfDay 0 0 (fromIntegral 0)) assertParseEqual (parseWithCtx nullctx p "2011/1/1 00:00-0800") startofday assertParseEqual (parseWithCtx nullctx p "2011/1/1 00:00+1234") startofday ,"defaultyeardirective" ~: do assertParse (parseWithCtx nullctx defaultyeardirective "Y 2010\n") assertParse (parseWithCtx nullctx defaultyeardirective "Y 10001\n") ,"historicalpricedirective" ~: assertParseEqual (parseWithCtx nullctx historicalpricedirective "P 2004/05/01 XYZ $55.00\n") (HistoricalPrice (parsedate "2004/05/01") "XYZ" $ usd 55) ,"ignoredpricecommoditydirective" ~: do assertParse (parseWithCtx nullctx ignoredpricecommoditydirective "N $\n") ,"defaultcommoditydirective" ~: do assertParse (parseWithCtx nullctx defaultcommoditydirective "D $1,000.0\n") ,"commodityconversiondirective" ~: do assertParse (parseWithCtx nullctx commodityconversiondirective "C 1h = $50.00\n") ,"tagdirective" ~: do assertParse (parseWithCtx nullctx tagdirective "tag foo \n") ,"endtagdirective" ~: do assertParse (parseWithCtx nullctx endtagdirective "end tag \n") assertParse (parseWithCtx nullctx endtagdirective "pop \n") ,"accountname" ~: do assertBool "accountname parses a normal accountname" (isRight $ parsewith accountname "a:b:c") assertBool "accountname rejects an empty inner component" (isLeft $ parsewith accountname "a::c") assertBool "accountname rejects an empty leading component" (isLeft $ parsewith accountname ":b:c") assertBool "accountname rejects an empty trailing component" (isLeft $ parsewith accountname "a:b:") ,"leftsymbolamount" ~: do assertParseEqual (parseWithCtx nullctx leftsymbolamount "$1") (usd 1 `withPrecision` 0) assertParseEqual (parseWithCtx nullctx leftsymbolamount "$-1") (usd (-1) `withPrecision` 0) assertParseEqual (parseWithCtx nullctx leftsymbolamount "-$1") (usd (-1) `withPrecision` 0) ,"amount" ~: do let -- | compare a parse result with an expected amount, showing the debug representation for clarity assertAmountParse parseresult amount = (either (const "parse error") showAmountDebug parseresult) ~?= (showAmountDebug amount) assertAmountParse (parseWithCtx nullctx amountp "1 @ $2") (num 1 `withPrecision` 0 `at` (usd 2 `withPrecision` 0)) ]] -} hledger-lib-0.22/Hledger/Read/TimelogReader.hs0000644000000000000000000000665412252750510017317 0ustar0000000000000000{-| A reader for the timelog file format generated by timeclock.el (). Example: @ i 2007\/03\/10 12:26:00 hledger o 2007\/03\/10 17:26:02 @ From timeclock.el 2.6: @ A timelog contains data in the form of a single entry per line. Each entry has the form: CODE YYYY/MM/DD HH:MM:SS [COMMENT] CODE is one of: b, h, i, o or O. COMMENT is optional when the code is i, o or O. The meanings of the codes are: b Set the current time balance, or \"time debt\". Useful when archiving old log data, when a debt must be carried forward. The COMMENT here is the number of seconds of debt. h Set the required working time for the given day. This must be the first entry for that day. The COMMENT in this case is the number of hours in this workday. Floating point amounts are allowed. i Clock in. The COMMENT in this case should be the name of the project worked on. o Clock out. COMMENT is unnecessary, but can be used to provide a description of how the period went, for example. O Final clock out. Whatever project was being worked on, it is now finished. Useful for creating summary reports. @ -} module Hledger.Read.TimelogReader ( -- * Reader reader, -- * Tests tests_Hledger_Read_TimelogReader ) where import Control.Monad import Control.Monad.Error import Test.HUnit import Text.ParserCombinators.Parsec hiding (parse) import System.FilePath import Hledger.Data -- XXX too much reuse ? import Hledger.Read.JournalReader ( directive, historicalpricedirective, defaultyeardirective, emptyline, datetime, parseJournalWith, getParentAccount ) import Hledger.Utils reader :: Reader reader = Reader format detect parse format :: String format = "timelog" -- | Does the given file path and data provide timeclock.el's timelog format ? detect :: FilePath -> String -> Bool detect f _ = takeExtension f == '.':format -- | Parse and post-process a "Journal" from timeclock.el's timelog -- format, saving the provided file path and the current time, or give an -- error. parse :: Maybe FilePath -> FilePath -> String -> ErrorT String IO Journal parse _ = -- trace ("running "++format++" reader") . parseJournalWith timelogFile timelogFile :: GenParser Char JournalContext (JournalUpdate,JournalContext) timelogFile = do items <- many timelogItem eof ctx <- getState return (liftM (foldr (.) id) $ sequence items, ctx) where -- As all ledger line types can be distinguished by the first -- character, excepting transactions versus empty (blank or -- comment-only) lines, can use choice w/o try timelogItem = choice [ directive , liftM (return . addHistoricalPrice) historicalpricedirective , defaultyeardirective , emptyline >> return (return id) , liftM (return . addTimeLogEntry) timelogentry ] "timelog entry, or default year or historical price directive" -- | Parse a timelog entry. timelogentry :: GenParser Char JournalContext TimeLogEntry timelogentry = do code <- oneOf "bhioO" many1 spacenonewline datetime <- datetime comment <- optionMaybe (many1 spacenonewline >> liftM2 (++) getParentAccount restofline) return $ TimeLogEntry (read [code]) datetime (maybe "" rstrip comment) tests_Hledger_Read_TimelogReader = TestList [ ] hledger-lib-0.22/Hledger/Read/CsvReader.hs0000644000000000000000000006666212252750510016457 0ustar0000000000000000{-| A reader for CSV data, using an extra rules file to help interpret the data. -} module Hledger.Read.CsvReader ( -- * Reader reader, -- * Misc. CsvRecord, -- rules, rulesFileFor, parseRulesFile, transactionFromCsvRecord, -- * Tests tests_Hledger_Read_CsvReader ) where import Control.Applicative ((<$>)) import Control.Exception hiding (try) import Control.Monad import Control.Monad.Error -- import Test.HUnit import Data.Char (toLower, isDigit, isSpace) import Data.List import Data.Maybe import Data.Ord import Data.Time.Calendar (Day) import Data.Time.Format (parseTime) import Safe import System.Directory (doesFileExist) import System.FilePath import System.IO (stderr) import System.Locale (defaultTimeLocale) import Test.HUnit import Text.CSV (parseCSV, CSV) import Text.ParserCombinators.Parsec hiding (parse) import Text.ParserCombinators.Parsec.Error import Text.ParserCombinators.Parsec.Pos import Text.Printf (hPrintf,printf) import Hledger.Data import Prelude hiding (getContents) import Hledger.Utils.UTF8IOCompat (getContents) import Hledger.Utils import Hledger.Read.JournalReader (amountp) reader :: Reader reader = Reader format detect parse format :: String format = "csv" -- | Does the given file path and data look like CSV ? detect :: FilePath -> String -> Bool detect f _ = takeExtension f == '.':format -- | Parse and post-process a "Journal" from CSV data, or give an error. -- XXX currently ignores the string and reads from the file path parse :: Maybe FilePath -> FilePath -> String -> ErrorT String IO Journal parse rulesfile f s = -- trace ("running "++format++" reader") $ do r <- liftIO $ readJournalFromCsv rulesfile f s case r of Left e -> throwError e Right j -> return j -- | Read a Journal from the given CSV data (and filename, used for error -- messages), or return an error. Proceed as follows: -- @ -- 1. parse the CSV data -- 2. identify the name of a file specifying conversion rules: either use -- the name provided, derive it from the CSV filename, or raise an error -- if the CSV filename is -. -- 3. auto-create the rules file with default rules if it doesn't exist -- 4. parse the rules file -- 5. convert the CSV records to a journal using the rules -- @ readJournalFromCsv :: Maybe FilePath -> FilePath -> String -> IO (Either String Journal) readJournalFromCsv Nothing "-" _ = return $ Left "please use --rules-file when converting stdin" readJournalFromCsv mrulesfile csvfile csvdata = handle (\e -> return $ Left $ show (e :: IOException)) $ do let throwerr = throw.userError -- parse csv records <- (either throwerr id . validateCsv) `fmap` parseCsv csvfile csvdata return $ dbg "" $ take 3 records -- identify header lines -- let (headerlines, datalines) = identifyHeaderLines records -- mfieldnames = lastMay headerlines -- parse rules let rulesfile = fromMaybe (rulesFileFor csvfile) mrulesfile created <- records `seq` ensureRulesFileExists rulesfile if created then hPrintf stderr "creating default conversion rules file %s, edit this file for better results\n" rulesfile else hPrintf stderr "using conversion rules file %s\n" rulesfile rules <- either (throwerr.show) id `fmap` parseRulesFile rulesfile return $ dbg "" rules -- apply skip directive let headerlines = maybe 0 oneorerror $ getDirective "skip" rules where oneorerror "" = 1 oneorerror s = readDef (throwerr $ "could not parse skip value: " ++ show s) s records' = drop headerlines records -- convert to transactions and return as a journal let txns = map (transactionFromCsvRecord rules) records' return $ Right nulljournal{jtxns=sortBy (comparing tdate) txns} parseCsv :: FilePath -> String -> IO (Either ParseError CSV) parseCsv path csvdata = case path of "-" -> liftM (parseCSV "(stdin)") getContents _ -> return $ parseCSV path csvdata -- | Return the cleaned up and validated CSV data, or an error. validateCsv :: Either ParseError CSV -> Either String [CsvRecord] validateCsv (Left e) = Left $ show e validateCsv (Right rs) = validate $ filternulls rs where filternulls = filter (/=[""]) validate [] = Left "no CSV records found" validate rs@(first:_) | isJust lessthan2 = let r = fromJust lessthan2 in Left $ printf "CSV record %s has less than two fields" (show r) | isJust different = let r = fromJust different in Left $ printf "the first CSV record %s has %d fields but %s has %d" (show first) length1 (show r) (length r) | otherwise = Right rs where length1 = length first lessthan2 = headMay $ filter ((<2).length) rs different = headMay $ filter ((/=length1).length) rs -- -- | The highest (0-based) field index referenced in the field -- -- definitions, or -1 if no fields are defined. -- maxFieldIndex :: CsvRules -> Int -- maxFieldIndex r = maximumDef (-1) $ catMaybes [ -- dateField r -- ,statusField r -- ,codeField r -- ,amountField r -- ,amountInField r -- ,amountOutField r -- ,currencyField r -- ,accountField r -- ,account2Field r -- ,date2Field r -- ] -- rulesFileFor :: CliOpts -> FilePath -> FilePath -- rulesFileFor CliOpts{rules_file_=Just f} _ = f -- rulesFileFor CliOpts{rules_file_=Nothing} csvfile = replaceExtension csvfile ".rules" rulesFileFor :: FilePath -> FilePath rulesFileFor = (++ ".rules") csvFileFor :: FilePath -> FilePath csvFileFor = reverse . drop 6 . reverse -- | Ensure there is a conversion rules file at the given path, creating a -- default one if needed and returning True in this case. ensureRulesFileExists :: FilePath -> IO Bool ensureRulesFileExists f = do exists <- doesFileExist f if exists then return False else do -- note Hledger.Utils.UTF8.* do no line ending conversion on windows, -- we currently require unix line endings on all platforms. writeFile f $ newRulesFileContent f return True newRulesFileContent :: FilePath -> String newRulesFileContent f = unlines ["# hledger csv conversion rules for " ++ csvFileFor (takeFileName f) ,"# cf http://hledger.org/MANUAL.html" ,"" ,"account1 assets:bank:checking" ,"" ,"fields date, description, amount" ,"" ,"#skip 1" ,"" ,"#date-format %-d/%-m/%Y" ,"#date-format %-m/%-d/%Y" ,"#date-format %Y-%h-%d" ,"" ,"#currency $" ,"" ,"if ITUNES" ," account2 expenses:entertainment" ,"" ,"if (TO|FROM) SAVINGS" ," account2 assets:bank:savings\n" ] -------------------------------------------------------------------------------- -- Conversion rules parsing {- Grammar for the CSV conversion rules, more or less: RULES: RULE* RULE: ( FIELD-LIST | FIELD-ASSIGNMENT | CONDITIONAL-BLOCK | SKIP | DATE-FORMAT | COMMENT | BLANK ) NEWLINE FIELD-LIST: fields SPACE FIELD-NAME ( SPACE? , SPACE? FIELD-NAME )* FIELD-NAME: QUOTED-FIELD-NAME | BARE-FIELD-NAME QUOTED-FIELD-NAME: " (any CHAR except double-quote)+ " BARE-FIELD-NAME: any CHAR except space, tab, #, ; FIELD-ASSIGNMENT: JOURNAL-FIELD ASSIGNMENT-SEPARATOR FIELD-VALUE JOURNAL-FIELD: date | date2 | status | code | description | comment | account1 | account2 | amount | JOURNAL-PSEUDO-FIELD JOURNAL-PSEUDO-FIELD: amount-in | amount-out | currency ASSIGNMENT-SEPARATOR: SPACE | ( : SPACE? ) FIELD-VALUE: VALUE (possibly containing CSV-FIELD-REFERENCEs) CSV-FIELD-REFERENCE: % CSV-FIELD CSV-FIELD: ( FIELD-NAME | FIELD-NUMBER ) (corresponding to a CSV field) FIELD-NUMBER: DIGIT+ CONDITIONAL-BLOCK: if ( FIELD-MATCHER NEWLINE )+ INDENTED-BLOCK FIELD-MATCHER: ( CSV-FIELD-NAME SPACE? )? ( MATCHOP SPACE? )? PATTERNS MATCHOP: ~ PATTERNS: ( NEWLINE REGEXP )* REGEXP INDENTED-BLOCK: ( SPACE ( FIELD-ASSIGNMENT | COMMENT ) NEWLINE )+ REGEXP: ( NONSPACE CHAR* ) SPACE? VALUE: SPACE? ( CHAR* ) SPACE? COMMENT: SPACE? COMMENT-CHAR VALUE COMMENT-CHAR: # | ; NONSPACE: any CHAR not a SPACE-CHAR BLANK: SPACE? SPACE: SPACE-CHAR+ SPACE-CHAR: space | tab CHAR: any character except newline DIGIT: 0-9 -} {- | A set of data definitions and account-matching patterns sufficient to convert a particular CSV data file into meaningful journal transactions. -} data CsvRules = CsvRules { rdirectives :: [(DirectiveName,String)], rcsvfieldindexes :: [(CsvFieldName, CsvFieldIndex)], rassignments :: [(JournalFieldName, FieldTemplate)], rconditionalblocks :: [ConditionalBlock] } deriving (Show, Eq) type DirectiveName = String type CsvFieldName = String type CsvFieldIndex = Int type JournalFieldName = String type FieldTemplate = String type ConditionalBlock = ([RecordMatcher], [(JournalFieldName, FieldTemplate)]) -- block matches if all RecordMatchers match type RecordMatcher = [Regexp] -- match if any regexps match any of the csv fields -- type FieldMatcher = (CsvFieldName, [Regexp]) -- match if any regexps match this csv field type DateFormat = String type Regexp = String rules = CsvRules { rdirectives=[], rcsvfieldindexes=[], rassignments=[], rconditionalblocks=[] } addDirective :: (DirectiveName, String) -> CsvRules -> CsvRules addDirective d r = r{rdirectives=d:rdirectives r} addAssignment :: (JournalFieldName, FieldTemplate) -> CsvRules -> CsvRules addAssignment a r = r{rassignments=a:rassignments r} setIndexesAndAssignmentsFromList :: [CsvFieldName] -> CsvRules -> CsvRules setIndexesAndAssignmentsFromList fs r = addAssignmentsFromList fs . setCsvFieldIndexesFromList fs $ r setCsvFieldIndexesFromList :: [CsvFieldName] -> CsvRules -> CsvRules setCsvFieldIndexesFromList fs r = r{rcsvfieldindexes=zip fs [1..]} addAssignmentsFromList :: [CsvFieldName] -> CsvRules -> CsvRules addAssignmentsFromList fs r = foldl' maybeAddAssignment r journalfieldnames where maybeAddAssignment rules f = (maybe id addAssignmentFromIndex $ elemIndex f fs) rules where addAssignmentFromIndex i = addAssignment (f, "%"++show (i+1)) addConditionalBlock :: ConditionalBlock -> CsvRules -> CsvRules addConditionalBlock b r = r{rconditionalblocks=b:rconditionalblocks r} getDirective :: DirectiveName -> CsvRules -> Maybe FieldTemplate getDirective directivename = lookup directivename . rdirectives parseRulesFile :: FilePath -> IO (Either ParseError CsvRules) parseRulesFile f = do s <- readFile' f >>= expandIncludes let rules = parseCsvRules f s return $ case rules of Left e -> Left e Right r -> case validateRules r of Left e -> Left $ toParseError e Right r -> Right r where toParseError s = newErrorMessage (Message s) (initialPos "") -- | Pre-parse csv rules to interpolate included files, recursively. -- This is a cheap hack to avoid rewriting the existing parser. expandIncludes :: String -> IO String expandIncludes s = do let (ls,rest) = break (isPrefixOf "include") $ lines s case rest of [] -> return $ unlines ls (('i':'n':'c':'l':'u':'d':'e':f):ls') -> do let f' = dropWhile isSpace f included <- readFile f' >>= expandIncludes return $ unlines [unlines ls, included, unlines ls'] ls' -> return $ unlines $ ls ++ ls' -- should never get here parseCsvRules :: FilePath -> String -> Either ParseError CsvRules -- parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s parseCsvRules rulesfile s = runParser rulesp rules rulesfile s -- | Return the validated rules, or an error. validateRules :: CsvRules -> Either String CsvRules validateRules rules = do unless (isAssigned "date") $ Left "Please specify (at top level) the date field. Eg: date %1\n" unless ((amount && not (amountin || amountout)) || (not amount && (amountin && amountout))) $ Left "Please specify (at top level) either the amount field, or both the amount-in and amount-out fields. Eg: amount %2\n" Right rules where amount = isAssigned "amount" amountin = isAssigned "amount-in" amountout = isAssigned "amount-out" isAssigned f = isJust $ getEffectiveAssignment rules [] f -- parsers rulesp :: GenParser Char CsvRules CsvRules rulesp = do many $ choice' [blankorcommentline "blank or comment line" ,(directive >>= updateState . addDirective) "directive" ,(fieldnamelist >>= updateState . setIndexesAndAssignmentsFromList) "field name list" ,(fieldassignment >>= updateState . addAssignment) "field assignment" ,(conditionalblock >>= updateState . addConditionalBlock) "conditional block" ] eof r <- getState return r{rdirectives=reverse $ rdirectives r ,rassignments=reverse $ rassignments r ,rconditionalblocks=reverse $ rconditionalblocks r } blankorcommentline = pdbg 1 "trying blankorcommentline" >> choice' [blankline, commentline] blankline = many spacenonewline >> newline >> return () "blank line" commentline = many spacenonewline >> commentchar >> restofline >> return () "comment line" commentchar = oneOf ";#" directive = do pdbg 1 "trying directive" d <- choice' $ map string directives v <- (((char ':' >> many spacenonewline) <|> many1 spacenonewline) >> directiveval) <|> (optional (char ':') >> many spacenonewline >> eolof >> return "") return (d,v) "directive" directives = ["date-format" -- ,"default-account1" -- ,"default-currency" -- ,"skip-lines" -- old ,"skip" -- ,"base-account" -- ,"base-currency" ] directiveval = anyChar `manyTill` eolof fieldnamelist = (do pdbg 1 "trying fieldnamelist" string "fields" optional $ char ':' many1 spacenonewline f <- fieldname let separator = many spacenonewline >> char ',' >> many spacenonewline fs <- many1 $ (separator >> fromMaybe "" <$> optionMaybe fieldname) restofline return $ map (map toLower) $ f:fs ) "field name list" fieldname = quotedfieldname <|> barefieldname quotedfieldname = do char '"' f <- many1 $ noneOf "\"\n:;#~" char '"' return f barefieldname = many1 $ noneOf " \t\n,;#~" fieldassignment = do pdbg 1 "trying fieldassignment" f <- journalfieldname assignmentseparator v <- fieldval return (f,v) "field assignment" journalfieldname = pdbg 2 "trying journalfieldname" >> choice' (map string journalfieldnames) journalfieldnames = [-- pseudo fields: "amount-in" ,"amount-out" ,"currency" -- standard fields: ,"date2" ,"date" ,"status" ,"code" ,"description" ,"amount" ,"account1" ,"account2" ,"comment" ] assignmentseparator = do pdbg 3 "trying assignmentseparator" choice [ -- try (many spacenonewline >> oneOf ":="), try (many spacenonewline >> char ':'), space ] many spacenonewline fieldval = do pdbg 2 "trying fieldval" anyChar `manyTill` eolof conditionalblock = do pdbg 1 "trying conditionalblock" string "if" >> many spacenonewline >> optional newline ms <- many1 recordmatcher as <- many (many1 spacenonewline >> fieldassignment) when (null as) $ fail "start of conditional block found, but no assignment rules afterward\n(assignment rules in a conditional block should be indented)\n" return (ms, as) "conditional block" recordmatcher = do pdbg 2 "trying recordmatcher" -- pos <- currentPos _ <- optional (matchoperator >> many spacenonewline >> optional newline) ps <- patterns when (null ps) $ fail "start of record matcher found, but no patterns afterward\n(patterns should not be indented)\n" return ps "record matcher" matchoperator = choice' $ map string ["~" -- ,"!~" -- ,"=" -- ,"!=" ] patterns = do pdbg 3 "trying patterns" ps <- many regexp return ps regexp = do pdbg 3 "trying regexp" notFollowedBy matchoperator c <- nonspace cs <- anyChar `manyTill` eolof return $ strip $ c:cs -- fieldmatcher = do -- pdbg 2 "trying fieldmatcher" -- f <- fromMaybe "all" `fmap` (optionMaybe $ do -- f' <- fieldname -- many spacenonewline -- return f') -- char '~' -- many spacenonewline -- ps <- patterns -- let r = "(" ++ intercalate "|" ps ++ ")" -- return (f,r) -- "field matcher" -------------------------------------------------------------------------------- -- Converting CSV records to journal transactions type CsvRecord = [String] -- Convert a CSV record to a transaction using the rules, or raise an -- error if the data can not be parsed. transactionFromCsvRecord :: CsvRules -> CsvRecord -> Transaction transactionFromCsvRecord rules record = t where mdirective = (`getDirective` rules) mfieldtemplate = getEffectiveAssignment rules record render = renderTemplate rules record mskip = mdirective "skip" mdefaultcurrency = mdirective "default-currency" mparsedate = parseDateWithFormatOrDefaultFormats (mdirective "date-format") -- render each field using its template and the csv record, and -- in some cases parse the rendered string (eg dates and amounts) mdateformat = mdirective "date-format" date = render $ fromMaybe "" $ mfieldtemplate "date" date' = fromMaybe (error' $ dateerror "date" date mdateformat) $ mparsedate date mdate2 = maybe Nothing (Just . render) $ mfieldtemplate "date2" mdate2' = maybe Nothing (maybe (error' $ dateerror "date2" (fromMaybe "" mdate2) mdateformat) Just . mparsedate) mdate2 dateerror datefield value mdateformat = unlines ["error: could not parse \""++value++"\" as a date using date format "++maybe "\"YYYY/M/D\", \"YYYY-M-D\" or \"YYYY.M.D\"" show mdateformat ,"the CSV record is: "++intercalate ", " (map show record) ,"the "++datefield++" rule is: "++(fromMaybe "required, but missing" $ mfieldtemplate datefield) ,"the date-format is: "++fromMaybe "unspecified" mdateformat ,"you may need to " ++"change your "++datefield++" rule, " ++maybe "add a" (const "change your") mdateformat++" date-format rule, " ++"or "++maybe "add a" (const "change your") mskip++" skip rule" ,"for m/d/y or d/m/y dates, use date-format %-m/%-d/%Y or date-format %-d/%-m/%Y" ] status = maybe False ((=="*") . render) $ mfieldtemplate "status" code = maybe "" render $ mfieldtemplate "code" description = maybe "" render $ mfieldtemplate "description" comment = maybe "" render $ mfieldtemplate "comment" precomment = maybe "" render $ mfieldtemplate "precomment" currency = maybe (fromMaybe "" mdefaultcurrency) render $ mfieldtemplate "currency" amountstr = (currency++) $ negateIfParenthesised $ getAmountStr rules record amount = either amounterror mixed $ runParser (do {a <- amountp; eof; return a}) nullctx "" amountstr amounterror err = error' $ unlines ["error: could not parse \""++amountstr++"\" as an amount" ,showRecord record ,"the amount rule is: "++(fromMaybe "" $ mfieldtemplate "amount") ,"the currency rule is: "++(fromMaybe "unspecified" $ mfieldtemplate "currency") ,"the default-currency is: "++fromMaybe "unspecified" mdefaultcurrency ,"the parse error is: "++show err ,"you may need to " ++"change your amount or currency rules, " ++"or "++maybe "add a" (const "change your") mskip++" skip rule" ] -- Using costOfMixedAmount here to allow complex costs like "10 GBP @@ 15 USD". -- Aim is to have "10 GBP @@ 15 USD" applied to account2, but have "-15USD" applied to account1 amount1 = costOfMixedAmount amount amount2 = (-amount) s `or` def = if null s then def else s defaccount1 = fromMaybe "unknown" $ mdirective "default-account1" defaccount2 = case isNegativeMixedAmount amount2 of Just True -> "income:unknown" _ -> "expenses:unknown" account1 = maybe "" render (mfieldtemplate "account1") `or` defaccount1 account2 = maybe "" render (mfieldtemplate "account2") `or` defaccount2 -- build the transaction t = nulltransaction{ tdate = date', tdate2 = mdate2', tstatus = status, tcode = code, tdescription = description, tcomment = comment, tpreceding_comment_lines = precomment, tpostings = [posting {paccount=account2, pamount=amount2, ptransaction=Just t} ,posting {paccount=account1, pamount=amount1, ptransaction=Just t} ] } getAmountStr :: CsvRules -> CsvRecord -> String getAmountStr rules record = let mamount = getEffectiveAssignment rules record "amount" mamountin = getEffectiveAssignment rules record "amount-in" mamountout = getEffectiveAssignment rules record "amount-out" render = fmap (strip . renderTemplate rules record) in case (render mamount, render mamountin, render mamountout) of (Just "", Nothing, Nothing) -> error' $ "amount has no value\n"++showRecord record (Just a, Nothing, Nothing) -> a (Nothing, Just "", Just "") -> error' $ "neither amount-in or amount-out has a value\n"++showRecord record (Nothing, Just i, Just "") -> i (Nothing, Just "", Just o) -> negateStr o (Nothing, Just _, Just _) -> error' $ "both amount-in and amount-out have a value\n"++showRecord record _ -> error' $ "found values for amount and for amount-in/amount-out - please use either amount or amount-in/amount-out\n"++showRecord record negateIfParenthesised :: String -> String negateIfParenthesised ('(':s) | lastMay s == Just ')' = negateStr $ init s negateIfParenthesised s = s negateStr :: String -> String negateStr ('-':s) = s negateStr s = '-':s -- | Show a (approximate) recreation of the original CSV record. showRecord :: CsvRecord -> String showRecord r = "the CSV record is: "++intercalate ", " (map show r) -- | Given the conversion rules, a CSV record and a journal entry field name, find -- the template value ultimately assigned to this field, either at top -- level or in a matching conditional block. Conditional blocks' -- patterns are matched against an approximation of the original CSV -- record: all the field values with commas intercalated. getEffectiveAssignment :: CsvRules -> CsvRecord -> JournalFieldName -> Maybe FieldTemplate getEffectiveAssignment rules record f = lastMay $ assignmentsFor f where assignmentsFor f = map snd $ filter ((==f).fst) $ toplevelassignments ++ conditionalassignments where toplevelassignments = rassignments rules conditionalassignments = concatMap snd $ filter blockMatches $ blocksAssigning f where blocksAssigning f = filter (any ((==f).fst) . snd) $ rconditionalblocks rules blockMatches :: ConditionalBlock -> Bool blockMatches (matchers,_) = all matcherMatches matchers where matcherMatches :: RecordMatcher -> Bool -- matcherMatches pats = any patternMatches pats matcherMatches pats = patternMatches $ "(" ++ intercalate "|" pats ++ ")" where patternMatches :: Regexp -> Bool patternMatches pat = regexMatchesCIRegexCompat pat csvline where csvline = intercalate "," record renderTemplate :: CsvRules -> CsvRecord -> FieldTemplate -> String renderTemplate rules record t = regexReplaceBy "%[A-z0-9]+" replace t where replace ('%':pat) = maybe pat (\i -> atDef "" record (i-1)) mi where mi | all isDigit pat = readMay pat | otherwise = lookup pat $ rcsvfieldindexes rules replace pat = pat -- Parse the date string using the specified date-format, or if unspecified try these default formats: -- YYYY/MM/DD, YYYY-MM-DD, YYYY.MM.DD, MM/DD/YYYY (month and day can be 1 or 2 digits, year must be 4). parseDateWithFormatOrDefaultFormats :: Maybe DateFormat -> String -> Maybe Day parseDateWithFormatOrDefaultFormats mformat s = firstJust $ map parsewith formats where parsewith = flip (parseTime defaultTimeLocale) s formats = maybe ["%Y/%-m/%-d" ,"%Y-%-m-%-d" ,"%Y.%-m.%-d" -- ,"%-m/%-d/%Y" -- ,parseTime defaultTimeLocale "%Y/%m/%e" (take 5 s ++ "0" ++ drop 5 s) -- ,parseTime defaultTimeLocale "%Y-%m-%e" (take 5 s ++ "0" ++ drop 5 s) -- ,parseTime defaultTimeLocale "%m/%e/%Y" ('0':s) -- ,parseTime defaultTimeLocale "%m-%e-%Y" ('0':s) ] (:[]) mformat -------------------------------------------------------------------------------- -- tests tests_Hledger_Read_CsvReader = TestList (test_parser) -- ++ test_description_parsing) -- test_description_parsing = [ -- "description-field 1" ~: assertParseDescription "description-field 1\n" [FormatField False Nothing Nothing (FieldNo 1)] -- , "description-field 1 " ~: assertParseDescription "description-field 1 \n" [FormatField False Nothing Nothing (FieldNo 1)] -- , "description-field %(1)" ~: assertParseDescription "description-field %(1)\n" [FormatField False Nothing Nothing (FieldNo 1)] -- , "description-field %(1)/$(2)" ~: assertParseDescription "description-field %(1)/%(2)\n" [ -- FormatField False Nothing Nothing (FieldNo 1) -- , FormatLiteral "/" -- , FormatField False Nothing Nothing (FieldNo 2) -- ] -- ] -- where -- assertParseDescription string expected = do assertParseEqual (parseDescription string) (rules {descriptionField = expected}) -- parseDescription :: String -> Either ParseError CsvRules -- parseDescription x = runParser descriptionfieldWrapper rules "(unknown)" x -- descriptionfieldWrapper :: GenParser Char CsvRules CsvRules -- descriptionfieldWrapper = do -- descriptionfield -- r <- getState -- return r test_parser = [ "convert rules parsing: empty file" ~: do -- let assertMixedAmountParse parseresult mixedamount = -- (either (const "parse error") showMixedAmountDebug parseresult) ~?= (showMixedAmountDebug mixedamount) assertParseEqual (parseCsvRules "unknown" "") rules -- ,"convert rules parsing: accountrule" ~: do -- assertParseEqual (parseWithCtx rules accountrule "A\na\n") -- leading blank line required -- ([("A",Nothing)], "a") ,"convert rules parsing: trailing comments" ~: do assertParse (parseWithCtx rules rulesp "skip\n# \n#\n") ,"convert rules parsing: trailing blank lines" ~: do assertParse (parseWithCtx rules rulesp "skip\n\n \n") -- not supported -- ,"convert rules parsing: no final newline" ~: do -- assertParse (parseWithCtx rules csvrulesfile "A\na") -- assertParse (parseWithCtx rules csvrulesfile "A\na\n# \n#") -- assertParse (parseWithCtx rules csvrulesfile "A\na\n\n ") -- (rules{ -- -- dateField=Maybe FieldPosition, -- -- statusField=Maybe FieldPosition, -- -- codeField=Maybe FieldPosition, -- -- descriptionField=Maybe FieldPosition, -- -- amountField=Maybe FieldPosition, -- -- currencyField=Maybe FieldPosition, -- -- baseCurrency=Maybe String, -- -- baseAccount=AccountName, -- accountRules=[ -- ([("A",Nothing)], "a") -- ] -- }) ] hledger-lib-0.22/Hledger/Utils/0000755000000000000000000000000012252750510014452 5ustar0000000000000000hledger-lib-0.22/Hledger/Utils/UTF8IOCompat.hs0000644000000000000000000000757012252750510017141 0ustar0000000000000000{-# LANGUAGE CPP #-} {- | UTF-8 aware string IO functions that will work across multiple platforms and GHC versions. Includes code from Text.Pandoc.UTF8 ((C) 2010 John MacFarlane). Example usage: import Prelude hiding (readFile,writeFile,appendFile,getContents,putStr,putStrLn) import UTF8IOCompat (readFile,writeFile,appendFile,getContents,putStr,putStrLn) import UTF8IOCompat (SystemString,fromSystemString,toSystemString,error',userError') 2013/4/10 update: we now trust that current GHC versions & platforms do the right thing, so this file is a no-op and on its way to being removed. Not carefully tested. -} module Hledger.Utils.UTF8IOCompat ( readFile, writeFile, appendFile, getContents, hGetContents, putStr, putStrLn, hPutStr, hPutStrLn, -- SystemString, fromSystemString, toSystemString, error', userError', ) where -- import Control.Monad (liftM) -- import qualified Data.ByteString.Lazy as B -- import qualified Data.ByteString.Lazy.Char8 as B8 -- import qualified Data.ByteString.Lazy.UTF8 as U8 (toString, fromString) import Prelude hiding (readFile, writeFile, appendFile, getContents, putStr, putStrLn) import System.IO -- (Handle) -- #if __GLASGOW_HASKELL__ < 702 -- import Codec.Binary.UTF8.String as UTF8 (decodeString, encodeString, isUTF8Encoded) -- import System.Info (os) -- #endif -- bom :: B.ByteString -- bom = B.pack [0xEF, 0xBB, 0xBF] -- stripBOM :: B.ByteString -> B.ByteString -- stripBOM s | bom `B.isPrefixOf` s = B.drop 3 s -- stripBOM s = s -- readFile :: FilePath -> IO String -- readFile = liftM (U8.toString . stripBOM) . B.readFile -- writeFile :: FilePath -> String -> IO () -- writeFile f = B.writeFile f . U8.fromString -- appendFile :: FilePath -> String -> IO () -- appendFile f = B.appendFile f . U8.fromString -- getContents :: IO String -- getContents = liftM (U8.toString . stripBOM) B.getContents -- hGetContents :: Handle -> IO String -- hGetContents h = liftM (U8.toString . stripBOM) (B.hGetContents h) -- putStr :: String -> IO () -- putStr = bs_putStr . U8.fromString -- putStrLn :: String -> IO () -- putStrLn = bs_putStrLn . U8.fromString -- hPutStr :: Handle -> String -> IO () -- hPutStr h = bs_hPutStr h . U8.fromString -- hPutStrLn :: Handle -> String -> IO () -- hPutStrLn h = bs_hPutStrLn h . U8.fromString -- -- span GHC versions including 6.12.3 - 7.4.1: -- bs_putStr = B8.putStr -- bs_putStrLn = B8.putStrLn -- bs_hPutStr = B8.hPut -- bs_hPutStrLn h bs = B8.hPut h bs >> B8.hPut h (B.singleton 0x0a) -- | A string received from or being passed to the operating system, such -- as a file path, command-line argument, or environment variable name or -- value. With GHC versions before 7.2 on some platforms (posix) these are -- typically encoded. When converting, we assume the encoding is UTF-8 (cf -- ). type SystemString = String -- | Convert a system string to an ordinary string, decoding from UTF-8 if -- it appears to be UTF8-encoded and GHC version is less than 7.2. fromSystemString :: SystemString -> String -- #if __GLASGOW_HASKELL__ < 702 -- fromSystemString s = if UTF8.isUTF8Encoded s then UTF8.decodeString s else s -- #else fromSystemString = id -- #endif -- | Convert a unicode string to a system string, encoding with UTF-8 if -- we are on a posix platform with GHC < 7.2. toSystemString :: String -> SystemString -- #if __GLASGOW_HASKELL__ < 702 -- toSystemString = case os of -- "unix" -> UTF8.encodeString -- "linux" -> UTF8.encodeString -- "darwin" -> UTF8.encodeString -- _ -> id -- #else toSystemString = id -- #endif -- | A SystemString-aware version of error. error' :: String -> a error' = error . toSystemString -- | A SystemString-aware version of userError. userError' :: String -> IOError userError' = userError . toSystemString hledger-lib-0.22/Hledger/Data/0000755000000000000000000000000012252750510014223 5ustar0000000000000000hledger-lib-0.22/Hledger/Data/FormatStrings.hs0000644000000000000000000001167012252750510017366 0ustar0000000000000000module Hledger.Data.FormatStrings ( parseFormatString , formatStrings , formatValue , FormatString(..) , HledgerFormatField(..) , tests ) where import Numeric import Data.Char (isPrint) import Data.Maybe import Test.HUnit import Text.ParserCombinators.Parsec import Text.Printf import Hledger.Data.Types formatValue :: Bool -> Maybe Int -> Maybe Int -> String -> String formatValue leftJustified min max value = printf formatS value where l = if leftJustified then "-" else "" min' = maybe "" show min max' = maybe "" (\i -> "." ++ (show i)) max formatS = "%" ++ l ++ min' ++ max' ++ "s" parseFormatString :: String -> Either String [FormatString] parseFormatString input = case (runParser formatStrings () "(unknown)") input of Left y -> Left $ show y Right x -> Right x {- Parsers -} field :: GenParser Char st HledgerFormatField field = do try (string "account" >> return AccountField) <|> try (string "depth_spacer" >> return DepthSpacerField) <|> try (string "date" >> return DescriptionField) <|> try (string "description" >> return DescriptionField) <|> try (string "total" >> return TotalField) <|> try (many1 digit >>= (\s -> return $ FieldNo $ read s)) formatField :: GenParser Char st FormatString formatField = do char '%' leftJustified <- optionMaybe (char '-') minWidth <- optionMaybe (many1 $ digit) maxWidth <- optionMaybe (do char '.'; many1 $ digit) -- TODO: Can this be (char '1') *> (many1 digit) char '(' f <- field char ')' return $ FormatField (isJust leftJustified) (parseDec minWidth) (parseDec maxWidth) f where parseDec s = case s of Just text -> Just m where ((m,_):_) = readDec text _ -> Nothing formatLiteral :: GenParser Char st FormatString formatLiteral = do s <- many1 c return $ FormatLiteral s where isPrintableButNotPercentage x = isPrint x && (not $ x == '%') c = (satisfy isPrintableButNotPercentage "printable character") <|> try (string "%%" >> return '%') formatString :: GenParser Char st FormatString formatString = formatField <|> formatLiteral formatStrings :: GenParser Char st [FormatString] formatStrings = many formatString testFormat :: FormatString -> String -> String -> Assertion testFormat fs value expected = assertEqual name expected actual where (name, actual) = case fs of FormatLiteral l -> ("literal", formatValue False Nothing Nothing l) FormatField leftJustify min max _ -> ("field", formatValue leftJustify min max value) testParser :: String -> [FormatString] -> Assertion testParser s expected = case (parseFormatString s) of Left error -> assertFailure $ show error Right actual -> assertEqual ("Input: " ++ s) expected actual tests = test [ formattingTests ++ parserTests ] formattingTests = [ testFormat (FormatLiteral " ") "" " " , testFormat (FormatField False Nothing Nothing DescriptionField) "description" "description" , testFormat (FormatField False (Just 20) Nothing DescriptionField) "description" " description" , testFormat (FormatField False Nothing (Just 20) DescriptionField) "description" "description" , testFormat (FormatField True Nothing (Just 20) DescriptionField) "description" "description" , testFormat (FormatField True (Just 20) Nothing DescriptionField) "description" "description " , testFormat (FormatField True (Just 20) (Just 20) DescriptionField) "description" "description " , testFormat (FormatField True Nothing (Just 3) DescriptionField) "description" "des" ] parserTests = [ testParser "" [] , testParser "D" [FormatLiteral "D"] , testParser "%(date)" [FormatField False Nothing Nothing DescriptionField] , testParser "%(total)" [FormatField False Nothing Nothing TotalField] , testParser "Hello %(date)!" [FormatLiteral "Hello ", FormatField False Nothing Nothing DescriptionField, FormatLiteral "!"] , testParser "%-(date)" [FormatField True Nothing Nothing DescriptionField] , testParser "%20(date)" [FormatField False (Just 20) Nothing DescriptionField] , testParser "%.10(date)" [FormatField False Nothing (Just 10) DescriptionField] , testParser "%20.10(date)" [FormatField False (Just 20) (Just 10) DescriptionField] , testParser "%20(account) %.10(total)\n" [ FormatField False (Just 20) Nothing AccountField , FormatLiteral " " , FormatField False Nothing (Just 10) TotalField , FormatLiteral "\n" ] ] hledger-lib-0.22/Hledger/Data/Commodity.hs0000644000000000000000000000413612252750510016527 0ustar0000000000000000{-| A 'Commodity' is a symbol representing a currency or some other kind of thing we are tracking, and some display preferences that tell how to display 'Amount's of the commodity - is the symbol on the left or right, are thousands separated by comma, significant decimal places and so on. -} module Hledger.Data.Commodity where import Data.List import Data.Maybe (fromMaybe) import Test.HUnit -- import qualified Data.Map as M import Hledger.Data.Types import Hledger.Utils -- characters than can't be in a non-quoted commodity symbol nonsimplecommoditychars = "0123456789-.@;\n \"{}=" :: String quoteCommoditySymbolIfNeeded s | any (`elem` nonsimplecommoditychars) s = "\"" ++ s ++ "\"" | otherwise = s commodity = "" -- handy constructors for tests -- unknown = commodity -- usd = "$" -- eur = "€" -- gbp = "£" -- hour = "h" -- Some sample commodity' names and symbols, for use in tests.. commoditysymbols = [("unknown","") ,("usd","$") ,("eur","€") ,("gbp","£") ,("hour","h") ] -- | Look up one of the sample commodities' symbol by name. comm :: String -> Commodity comm name = snd $ fromMaybe (error' "commodity lookup failed") (find (\n -> fst n == name) commoditysymbols) -- | Find the conversion rate between two commodities. Currently returns 1. conversionRate :: Commodity -> Commodity -> Double conversionRate _ _ = 1 -- -- | Convert a list of commodities to a map from commodity symbols to -- -- unique, display-preference-canonicalised commodities. -- canonicaliseCommodities :: [Commodity] -> Map.Map String Commodity -- canonicaliseCommodities cs = -- Map.fromList [(s,firstc{precision=maxp}) | s <- symbols, -- let cs = commoditymap ! s, -- let firstc = head cs, -- let maxp = maximum $ map precision cs -- ] -- where -- commoditymap = Map.fromList [(s, commoditieswithsymbol s) | s <- symbols] -- commoditieswithsymbol s = filter ((s==) . symbol) cs -- symbols = nub $ map symbol cs tests_Hledger_Data_Commodity = TestList [ ] hledger-lib-0.22/Hledger/Data/Ledger.hs0000644000000000000000000000670312252750510015767 0ustar0000000000000000{-| A 'Ledger' is derived from a 'Journal' by applying a filter specification to select 'Transaction's and 'Posting's of interest. It contains the filtered journal and knows the resulting chart of accounts, account balances, and postings in each account. -} module Hledger.Data.Ledger where import qualified Data.Map as M import Safe (headDef) import Test.HUnit import Text.Printf import Hledger.Data.Types import Hledger.Data.Account import Hledger.Data.Journal import Hledger.Data.Posting import Hledger.Query instance Show Ledger where show l = printf "Ledger with %d transactions, %d accounts\n" --"%s" (length (jtxns $ ljournal l) + length (jmodifiertxns $ ljournal l) + length (jperiodictxns $ ljournal l)) (length $ ledgerAccountNames l) -- (showtree $ ledgerAccountNameTree l) nullledger :: Ledger nullledger = Ledger { ljournal = nulljournal, laccounts = [] } -- | Filter a journal's transactions with the given query, then derive a -- ledger containing the chart of accounts and balances. If the query -- includes a depth limit, that will affect the ledger's journal but not -- the account tree. ledgerFromJournal :: Query -> Journal -> Ledger ledgerFromJournal q j = nullledger{ljournal=j'', laccounts=as} where (q',depthq) = (filterQuery (not . queryIsDepth) q, filterQuery queryIsDepth q) j' = filterJournalPostings q' j as = accountsFromPostings $ journalPostings j' j'' = filterJournalPostings depthq j' -- | List a ledger's account names. ledgerAccountNames :: Ledger -> [AccountName] ledgerAccountNames = drop 1 . map aname . laccounts -- | Get the named account from a ledger. ledgerAccount :: Ledger -> AccountName -> Maybe Account ledgerAccount l a = lookupAccount a $ laccounts l -- | Get this ledger's root account, which is a dummy "root" account -- above all others. This should always be first in the account list, -- if somehow not this returns a null account. ledgerRootAccount :: Ledger -> Account ledgerRootAccount = headDef nullacct . laccounts -- | List a ledger's top-level accounts (the ones below the root), in tree order. ledgerTopAccounts :: Ledger -> [Account] ledgerTopAccounts = asubs . head . laccounts -- | List a ledger's bottom-level (subaccount-less) accounts, in tree order. ledgerLeafAccounts :: Ledger -> [Account] ledgerLeafAccounts = filter (null.asubs) . laccounts -- | Accounts in ledger whose name matches the pattern, in tree order. ledgerAccountsMatching :: [String] -> Ledger -> [Account] ledgerAccountsMatching pats = filter (matchpats pats . aname) . laccounts -- | List a ledger's postings, in the order parsed. ledgerPostings :: Ledger -> [Posting] ledgerPostings = journalPostings . ljournal -- | The (fully specified) date span containing all the ledger's (filtered) transactions, -- or DateSpan Nothing Nothing if there are none. ledgerDateSpan :: Ledger -> DateSpan ledgerDateSpan = postingsDateSpan . ledgerPostings -- | All commodities used in this ledger. ledgerCommodities :: Ledger -> [Commodity] ledgerCommodities = M.keys . jcommoditystyles . ljournal tests_ledgerFromJournal = [ "ledgerFromJournal" ~: do assertEqual "" (0) (length $ ledgerPostings $ ledgerFromJournal Any nulljournal) assertEqual "" (11) (length $ ledgerPostings $ ledgerFromJournal Any samplejournal) assertEqual "" (6) (length $ ledgerPostings $ ledgerFromJournal (Depth 2) samplejournal) ] tests_Hledger_Data_Ledger = TestList $ tests_ledgerFromJournal hledger-lib-0.22/Hledger/Data/Journal.hs0000644000000000000000000006752212252750510016205 0ustar0000000000000000{-| A 'Journal' is a set of transactions, plus optional related data. This is hledger's primary data object. It is usually parsed from a journal file or other data format (see "Hledger.Read"). -} module Hledger.Data.Journal ( -- * Parsing helpers addHistoricalPrice, addModifierTransaction, addPeriodicTransaction, addTimeLogEntry, addTransaction, journalApplyAliases, journalBalanceTransactions, journalCanonicaliseAmounts, journalConvertAmountsToCost, journalFinalise, -- * Filtering filterJournalPostings, filterJournalTransactions, -- * Querying journalAccountNames, journalAccountNamesUsed, -- journalAmountAndPriceCommodities, journalAmounts, -- journalCanonicalCommodities, journalDateSpan, journalFilePath, journalFilePaths, journalPostings, -- * Standard account types journalBalanceSheetAccountQuery, journalProfitAndLossAccountQuery, journalIncomeAccountQuery, journalExpenseAccountQuery, journalAssetAccountQuery, journalLiabilityAccountQuery, journalEquityAccountQuery, journalCashAccountQuery, -- * Misc matchpats, nullctx, nulljournal, -- * Tests samplejournal, tests_Hledger_Data_Journal, ) where import Control.Monad import Data.List -- import Data.Map (findWithDefault) import Data.Maybe import Data.Ord import Data.Time.Calendar import Data.Time.LocalTime import Data.Tree import Safe (headDef) import System.Time (ClockTime(TOD)) import Test.HUnit import Text.Printf import qualified Data.Map as M import Hledger.Utils import Hledger.Data.Types import Hledger.Data.AccountName import Hledger.Data.Amount -- import Hledger.Data.Commodity import Hledger.Data.Dates import Hledger.Data.Transaction import Hledger.Data.Posting import Hledger.Data.TimeLog import Hledger.Query instance Show Journal where show j | debugLevel < 3 = printf "Journal %s with %d transactions, %d accounts" (journalFilePath j) (length (jtxns j) + length (jmodifiertxns j) + length (jperiodictxns j)) (length accounts) | debugLevel < 6 = printf "Journal %s with %d transactions, %d accounts: %s" (journalFilePath j) (length (jtxns j) + length (jmodifiertxns j) + length (jperiodictxns j)) (length accounts) (show accounts) | otherwise = printf "Journal %s with %d transactions, %d accounts: %s, commodity styles: %s" (journalFilePath j) (length (jtxns j) + length (jmodifiertxns j) + length (jperiodictxns j)) (length accounts) (show accounts) (show $ jcommoditystyles j) -- ++ (show $ journalTransactions l) where accounts = flatten $ journalAccountNameTree j -- showJournalDebug j = unlines [ -- show j -- ,show (jtxns j) -- ,show (jmodifiertxns j) -- ,show (jperiodictxns j) -- ,show $ open_timelog_entries j -- ,show $ historical_prices j -- ,show $ final_comment_lines j -- ,show $ jContext j -- ,show $ map fst $ files j -- ] nulljournal :: Journal nulljournal = Journal { jmodifiertxns = [] , jperiodictxns = [] , jtxns = [] , open_timelog_entries = [] , historical_prices = [] , final_comment_lines = [] , jContext = nullctx , files = [] , filereadtime = TOD 0 0 , jcommoditystyles = M.fromList [] } nullctx :: JournalContext nullctx = Ctx { ctxYear = Nothing, ctxCommodityAndStyle = Nothing, ctxAccount = [], ctxAliases = [] } journalFilePath :: Journal -> FilePath journalFilePath = fst . mainfile journalFilePaths :: Journal -> [FilePath] journalFilePaths = map fst . files mainfile :: Journal -> (FilePath, String) mainfile = headDef ("", "") . files addTransaction :: Transaction -> Journal -> Journal addTransaction t l0 = l0 { jtxns = t : jtxns l0 } addModifierTransaction :: ModifierTransaction -> Journal -> Journal addModifierTransaction mt l0 = l0 { jmodifiertxns = mt : jmodifiertxns l0 } addPeriodicTransaction :: PeriodicTransaction -> Journal -> Journal addPeriodicTransaction pt l0 = l0 { jperiodictxns = pt : jperiodictxns l0 } addHistoricalPrice :: HistoricalPrice -> Journal -> Journal addHistoricalPrice h l0 = l0 { historical_prices = h : historical_prices l0 } addTimeLogEntry :: TimeLogEntry -> Journal -> Journal addTimeLogEntry tle l0 = l0 { open_timelog_entries = tle : open_timelog_entries l0 } journalPostings :: Journal -> [Posting] journalPostings = concatMap tpostings . jtxns -- | All account names used in this journal. journalAccountNamesUsed :: Journal -> [AccountName] journalAccountNamesUsed = sort . accountNamesFromPostings . journalPostings journalAccountNames :: Journal -> [AccountName] journalAccountNames = sort . expandAccountNames . journalAccountNamesUsed journalAccountNameTree :: Journal -> Tree AccountName journalAccountNameTree = accountNameTreeFrom . journalAccountNames -- standard account types -- | A query for Profit & Loss accounts in this journal. -- Cf . journalProfitAndLossAccountQuery :: Journal -> Query journalProfitAndLossAccountQuery j = Or [journalIncomeAccountQuery j ,journalExpenseAccountQuery j ] -- | A query for Income (Revenue) accounts in this journal. -- This is currently hard-coded to the case-insensitive regex @^(income|revenue)s?(:|$)@. journalIncomeAccountQuery :: Journal -> Query journalIncomeAccountQuery _ = Acct "^(income|revenue)s?(:|$)" -- | A query for Expense accounts in this journal. -- This is currently hard-coded to the case-insensitive regex @^expenses?(:|$)@. journalExpenseAccountQuery :: Journal -> Query journalExpenseAccountQuery _ = Acct "^expenses?(:|$)" -- | A query for Asset, Liability & Equity accounts in this journal. -- Cf . journalBalanceSheetAccountQuery :: Journal -> Query journalBalanceSheetAccountQuery j = Or [journalAssetAccountQuery j ,journalLiabilityAccountQuery j ,journalEquityAccountQuery j ] -- | A query for Asset accounts in this journal. -- This is currently hard-coded to the case-insensitive regex @^assets?(:|$)@. journalAssetAccountQuery :: Journal -> Query journalAssetAccountQuery _ = Acct "^assets?(:|$)" -- | A query for Liability accounts in this journal. -- This is currently hard-coded to the case-insensitive regex @^liabilit(y|ies)(:|$)@. journalLiabilityAccountQuery :: Journal -> Query journalLiabilityAccountQuery _ = Acct "^liabilit(y|ies)(:|$)" -- | A query for Equity accounts in this journal. -- This is currently hard-coded to the case-insensitive regex @^equity(:|$)@. journalEquityAccountQuery :: Journal -> Query journalEquityAccountQuery _ = Acct "^equity(:|$)" -- | A query for Cash (-equivalent) accounts in this journal (ie, -- accounts which appear on the cashflow statement.) This is currently -- hard-coded to be all the Asset accounts except for those containing the -- case-insensitive regex @(receivable|A/R)@. journalCashAccountQuery :: Journal -> Query journalCashAccountQuery j = And [journalAssetAccountQuery j, Not $ Acct "(receivable|A/R)"] -- Various kinds of filtering on journals. We do it differently depending -- on the command. ------------------------------------------------------------------------------- -- filtering V2 -- | Keep only postings matching the query expression. -- This can leave unbalanced transactions. filterJournalPostings :: Query -> Journal -> Journal filterJournalPostings q j@Journal{jtxns=ts} = j{jtxns=map filtertransactionpostings ts} where filtertransactionpostings t@Transaction{tpostings=ps} = t{tpostings=filter (q `matchesPosting`) ps} -- | Keep only transactions matching the query expression. filterJournalTransactions :: Query -> Journal -> Journal filterJournalTransactions q j@Journal{jtxns=ts} = j{jtxns=filter (q `matchesTransaction`) ts} {- ------------------------------------------------------------------------------- -- filtering V1 -- | Keep only transactions we are interested in, as described by the -- filter specification. filterJournalTransactions :: FilterSpec -> Journal -> Journal filterJournalTransactions FilterSpec{datespan=datespan ,cleared=cleared -- ,real=real -- ,empty=empty ,acctpats=apats ,descpats=dpats ,depth=depth ,fMetadata=md } = filterJournalTransactionsByClearedStatus cleared . filterJournalPostingsByDepth depth . filterJournalTransactionsByAccount apats . filterJournalTransactionsByMetadata md . filterJournalTransactionsByDescription dpats . filterJournalTransactionsByDate datespan -- | Keep only postings we are interested in, as described by the filter -- specification. This can leave unbalanced transactions. filterJournalPostings :: FilterSpec -> Journal -> Journal filterJournalPostings FilterSpec{datespan=datespan ,cleared=cleared ,real=real ,empty=empty ,acctpats=apats ,descpats=dpats ,depth=depth ,fMetadata=md } = filterJournalPostingsByRealness real . filterJournalPostingsByClearedStatus cleared . filterJournalPostingsByEmpty empty . filterJournalPostingsByDepth depth . filterJournalPostingsByAccount apats . filterJournalTransactionsByMetadata md . filterJournalTransactionsByDescription dpats . filterJournalTransactionsByDate datespan -- | Keep only transactions whose metadata matches all metadata specifications. filterJournalTransactionsByMetadata :: [(String,String)] -> Journal -> Journal filterJournalTransactionsByMetadata pats j@Journal{jtxns=ts} = j{jtxns=filter matchmd ts} where matchmd t = all (`elem` tmetadata t) pats -- | Keep only transactions whose description matches the description patterns. filterJournalTransactionsByDescription :: [String] -> Journal -> Journal filterJournalTransactionsByDescription pats j@Journal{jtxns=ts} = j{jtxns=filter matchdesc ts} where matchdesc = matchpats pats . tdescription -- | Keep only transactions which fall between begin and end dates. -- We include transactions on the begin date and exclude transactions on the end -- date, like ledger. An empty date string means no restriction. filterJournalTransactionsByDate :: DateSpan -> Journal -> Journal filterJournalTransactionsByDate (DateSpan begin end) j@Journal{jtxns=ts} = j{jtxns=filter match ts} where match t = maybe True (tdate t>=) begin && maybe True (tdate t<) end -- | Keep only transactions which have the requested cleared/uncleared -- status, if there is one. filterJournalTransactionsByClearedStatus :: Maybe Bool -> Journal -> Journal filterJournalTransactionsByClearedStatus Nothing j = j filterJournalTransactionsByClearedStatus (Just val) j@Journal{jtxns=ts} = j{jtxns=filter match ts} where match = (==val).tstatus -- | Keep only postings which have the requested cleared/uncleared status, -- if there is one. filterJournalPostingsByClearedStatus :: Maybe Bool -> Journal -> Journal filterJournalPostingsByClearedStatus Nothing j = j filterJournalPostingsByClearedStatus (Just c) j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts} where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter ((==c) . postingCleared) ps} -- | Strip out any virtual postings, if the flag is true, otherwise do -- no filtering. filterJournalPostingsByRealness :: Bool -> Journal -> Journal filterJournalPostingsByRealness False j = j filterJournalPostingsByRealness True j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts} where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter isReal ps} -- | Strip out any postings with zero amount, unless the flag is true. filterJournalPostingsByEmpty :: Bool -> Journal -> Journal filterJournalPostingsByEmpty True j = j filterJournalPostingsByEmpty False j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts} where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter (not . isEmptyPosting) ps} -- -- | Keep only transactions which affect accounts deeper than the specified depth. -- filterJournalTransactionsByDepth :: Maybe Int -> Journal -> Journal -- filterJournalTransactionsByDepth Nothing j = j -- filterJournalTransactionsByDepth (Just d) j@Journal{jtxns=ts} = -- j{jtxns=(filter (any ((<= d+1) . accountNameLevel . paccount) . tpostings) ts)} -- | Strip out any postings to accounts deeper than the specified depth -- (and any transactions which have no postings as a result). filterJournalPostingsByDepth :: Maybe Int -> Journal -> Journal filterJournalPostingsByDepth Nothing j = j filterJournalPostingsByDepth (Just d) j@Journal{jtxns=ts} = j{jtxns=filter (not . null . tpostings) $ map filtertxns ts} where filtertxns t@Transaction{tpostings=ps} = t{tpostings=filter ((<= d) . accountNameLevel . paccount) ps} -- | Keep only postings which affect accounts matched by the account patterns. -- This can leave transactions unbalanced. filterJournalPostingsByAccount :: [String] -> Journal -> Journal filterJournalPostingsByAccount apats j@Journal{jtxns=ts} = j{jtxns=map filterpostings ts} where filterpostings t@Transaction{tpostings=ps} = t{tpostings=filter (matchpats apats . paccount) ps} -- | Keep only transactions which affect accounts matched by the account patterns. -- More precisely: each positive account pattern excludes transactions -- which do not contain a posting to a matched account, and each negative -- account pattern excludes transactions containing a posting to a matched -- account. filterJournalTransactionsByAccount :: [String] -> Journal -> Journal filterJournalTransactionsByAccount apats j@Journal{jtxns=ts} = j{jtxns=filter tmatch ts} where tmatch t = (null positives || any positivepmatch ps) && (null negatives || not (any negativepmatch ps)) where ps = tpostings t positivepmatch p = any (`amatch` a) positives where a = paccount p negativepmatch p = any (`amatch` a) negatives where a = paccount p amatch pat a = regexMatchesCI (abspat pat) a (negatives,positives) = partition isnegativepat apats -} -- | Apply additional account aliases (eg from the command-line) to all postings in a journal. journalApplyAliases :: [(AccountName,AccountName)] -> Journal -> Journal journalApplyAliases aliases j@Journal{jtxns=ts} = j{jtxns=map fixtransaction ts} where fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps} fixposting p@Posting{paccount=a} = p{paccount=accountNameApplyAliases aliases a} -- | Do post-parse processing on a journal to make it ready for use: check -- all transactions balance, canonicalise amount formats, close any open -- timelog entries and so on. journalFinalise :: ClockTime -> LocalTime -> FilePath -> String -> JournalContext -> Journal -> Either String Journal journalFinalise tclock tlocal path txt ctx j@Journal{files=fs} = do (journalBalanceTransactions $ journalCanonicaliseAmounts $ journalCloseTimeLogEntries tlocal j{files=(path,txt):fs, filereadtime=tclock, jContext=ctx}) >>= journalCheckBalanceAssertions -- | Check any balance assertions in the journal and return an error -- message if any of them fail. journalCheckBalanceAssertions :: Journal -> Either String Journal journalCheckBalanceAssertions j = do let postingsByAccount = groupBy (\p1 p2 -> paccount p1 == paccount p2) $ sortBy (comparing paccount) $ journalPostings j forM_ postingsByAccount checkBalanceAssertionsForAccount Right j -- Check any balance assertions in this sequence of postings to a single account. checkBalanceAssertionsForAccount :: [Posting] -> Either String () checkBalanceAssertionsForAccount ps | null errs = Right () | otherwise = Left $ head errs where errs = fst $ foldl' checkBalanceAssertion ([],nullmixedamt) $ splitAssertions $ sortBy (comparing postingDate) ps -- Given a starting balance, accumulated errors, and a non-null sequence of -- postings to a single account with a balance assertion in the last: -- check that the final balance matches the balance assertion. -- If it does, return the new balance, otherwise add an error to the -- error list. Intended to be called from a fold. checkBalanceAssertion :: ([String],MixedAmount) -> [Posting] -> ([String],MixedAmount) checkBalanceAssertion (errs,bal) ps | null ps = (errs,bal) | isNothing assertion = (errs,bal) | -- bal' /= assertedbal -- MixedAmount's Eq instance currently gets confused by different precisions not $ isReallyZeroMixedAmount (bal' - assertedbal) = (errs++[err], bal') | otherwise = (errs,bal') where p = last ps assertion = pbalanceassertion p Just assertedbal = assertion bal' = sum $ [bal] ++ map pamount ps err = printf "Balance assertion failed for account %s on %s\n%safter\n %s\nexpected balance is %s, actual balance was %s." (paccount p) (show $ postingDate p) (maybe "" (("In\n"++).show) $ ptransaction p) (show p) (showMixedAmount assertedbal) (showMixedAmount bal') -- Given a sequence of postings to a single account, split it into -- sub-sequences consisting of ordinary postings followed by a single -- balance-asserting posting. Postings not followed by a balance -- assertion are discarded. splitAssertions :: [Posting] -> [[Posting]] splitAssertions ps | null rest = [[]] | otherwise = (ps'++[head rest]):splitAssertions (tail rest) where (ps',rest) = break (isJust . pbalanceassertion) ps -- | Fill in any missing amounts and check that all journal transactions -- balance, or return an error message. This is done after parsing all -- amounts and working out the canonical commodities, since balancing -- depends on display precision. Reports only the first error encountered. journalBalanceTransactions :: Journal -> Either String Journal journalBalanceTransactions j@Journal{jtxns=ts, jcommoditystyles=ss} = case sequence $ map balance ts of Right ts' -> Right j{jtxns=map txnTieKnot ts'} Left e -> Left e where balance = balanceTransaction (Just ss) -- | Convert all the journal's posting amounts (not price amounts) to -- their canonical display settings. Ie, all amounts in a given -- commodity will use (a) the display settings of the first, and (b) -- the greatest precision, of the posting amounts in that commodity. journalCanonicaliseAmounts :: Journal -> Journal journalCanonicaliseAmounts j@Journal{jtxns=ts} = j'' where j'' = j'{jtxns=map fixtransaction ts} j' = j{jcommoditystyles = canonicalStyles $ journalAmounts j} fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps} fixposting p@Posting{pamount=a} = p{pamount=fixmixedamount a} fixmixedamount (Mixed as) = Mixed $ map fixamount as fixamount a@Amount{acommodity=c} = a{astyle=journalCommodityStyle j' c} -- | Get this journal's canonical amount style for the given commodity, or the null style. journalCommodityStyle :: Journal -> Commodity -> AmountStyle journalCommodityStyle j c = M.findWithDefault amountstyle c $ jcommoditystyles j -- -- | Apply this journal's historical price records to unpriced amounts where possible. -- journalApplyHistoricalPrices :: Journal -> Journal -- journalApplyHistoricalPrices j@Journal{jtxns=ts} = j{jtxns=map fixtransaction ts} -- where -- fixtransaction t@Transaction{tdate=d, tpostings=ps} = t{tpostings=map fixposting ps} -- where -- fixposting p@Posting{pamount=a} = p{pamount=fixmixedamount a} -- fixmixedamount (Mixed as) = Mixed $ map fixamount as -- fixamount = fixprice -- fixprice a@Amount{price=Just _} = a -- fixprice a@Amount{commodity=c} = a{price=maybe Nothing (Just . UnitPrice) $ journalHistoricalPriceFor j d c} -- -- | Get the price for a commodity on the specified day from the price database, if known. -- -- Does only one lookup step, ie will not look up the price of a price. -- journalHistoricalPriceFor :: Journal -> Day -> Commodity -> Maybe MixedAmount -- journalHistoricalPriceFor j d Commodity{symbol=s} = do -- let ps = reverse $ filter ((<= d).hdate) $ filter ((s==).hsymbol) $ sortBy (comparing hdate) $ historical_prices j -- case ps of (HistoricalPrice{hamount=a}:_) -> Just a -- _ -> Nothing -- | Close any open timelog sessions in this journal using the provided current time. journalCloseTimeLogEntries :: LocalTime -> Journal -> Journal journalCloseTimeLogEntries now j@Journal{jtxns=ts, open_timelog_entries=es} = j{jtxns = ts ++ (timeLogEntriesToTransactions now es), open_timelog_entries = []} -- | Convert all this journal's amounts to cost by applying their prices, if any. journalConvertAmountsToCost :: Journal -> Journal journalConvertAmountsToCost j@Journal{jtxns=ts} = j{jtxns=map fixtransaction ts} where -- similar to journalCanonicaliseAmounts fixtransaction t@Transaction{tpostings=ps} = t{tpostings=map fixposting ps} fixposting p@Posting{pamount=a} = p{pamount=fixmixedamount a} fixmixedamount (Mixed as) = Mixed $ map fixamount as fixamount = canonicaliseAmount (jcommoditystyles j) . costOfAmount -- -- | Get this journal's unique, display-preference-canonicalised commodities, by symbol. -- journalCanonicalCommodities :: Journal -> M.Map String Commodity -- journalCanonicalCommodities j = canonicaliseCommodities $ journalAmountCommodities j -- -- | Get all this journal's amounts' commodities, in the order parsed. -- journalAmountCommodities :: Journal -> [Commodity] -- journalAmountCommodities = map acommodity . concatMap amounts . journalAmounts -- -- | Get all this journal's amount and price commodities, in the order parsed. -- journalAmountAndPriceCommodities :: Journal -> [Commodity] -- journalAmountAndPriceCommodities = concatMap amountCommodities . concatMap amounts . journalAmounts -- -- | Get this amount's commodity and any commodities referenced in its price. -- amountCommodities :: Amount -> [Commodity] -- amountCommodities Amount{acommodity=c,aprice=p} = -- case p of Nothing -> [c] -- Just (UnitPrice ma) -> c:(concatMap amountCommodities $ amounts ma) -- Just (TotalPrice ma) -> c:(concatMap amountCommodities $ amounts ma) -- | Get all this journal's (mixed) amounts, in the order parsed. journalMixedAmounts :: Journal -> [MixedAmount] journalMixedAmounts = map pamount . journalPostings -- | Get all this journal's component amounts, roughly in the order parsed. journalAmounts :: Journal -> [Amount] journalAmounts = concatMap flatten . journalMixedAmounts where flatten (Mixed as) = as -- | The (fully specified) date span containing this journal's transactions, -- or DateSpan Nothing Nothing if there are none. journalDateSpan :: Journal -> DateSpan journalDateSpan j | null ts = DateSpan Nothing Nothing | otherwise = DateSpan (Just $ tdate $ head ts) (Just $ addDays 1 $ tdate $ last ts) where ts = sortBy (comparing tdate) $ jtxns j -- Misc helpers -- | Check if a set of hledger account/description filter patterns matches the -- given account name or entry description. Patterns are case-insensitive -- regular expressions. Prefixed with not:, they become anti-patterns. matchpats :: [String] -> String -> Bool matchpats pats str = (null positives || any match positives) && (null negatives || not (any match negatives)) where (negatives,positives) = partition isnegativepat pats match "" = True match pat = regexMatchesCI (abspat pat) str negateprefix = "not:" isnegativepat = (negateprefix `isPrefixOf`) abspat pat = if isnegativepat pat then drop (length negateprefix) pat else pat -- debug helpers -- traceAmountPrecision a = trace (show $ map (precision . acommodity) $ amounts a) a -- tracePostingsCommodities ps = trace (show $ map ((map (precision . acommodity) . amounts) . pamount) ps) ps -- tests -- A sample journal for testing, similar to data/sample.journal: -- -- 2008/01/01 income -- assets:bank:checking $1 -- income:salary -- -- 2008/06/01 gift -- assets:bank:checking $1 -- income:gifts -- -- 2008/06/02 save -- assets:bank:saving $1 -- assets:bank:checking -- -- 2008/06/03 * eat & shop -- expenses:food $1 -- expenses:supplies $1 -- assets:cash -- -- 2008/12/31 * pay off -- liabilities:debts $1 -- assets:bank:checking -- Right samplejournal = journalBalanceTransactions $ nulljournal {jtxns = [ txnTieKnot $ Transaction { tdate=parsedate "2008/01/01", tdate2=Nothing, tstatus=False, tcode="", tdescription="income", tcomment="", ttags=[], tpostings= ["assets:bank:checking" `post` usd 1 ,"income:salary" `post` missingamt ], tpreceding_comment_lines="" } , txnTieKnot $ Transaction { tdate=parsedate "2008/06/01", tdate2=Nothing, tstatus=False, tcode="", tdescription="gift", tcomment="", ttags=[], tpostings= ["assets:bank:checking" `post` usd 1 ,"income:gifts" `post` missingamt ], tpreceding_comment_lines="" } , txnTieKnot $ Transaction { tdate=parsedate "2008/06/02", tdate2=Nothing, tstatus=False, tcode="", tdescription="save", tcomment="", ttags=[], tpostings= ["assets:bank:saving" `post` usd 1 ,"assets:bank:checking" `post` usd (-1) ], tpreceding_comment_lines="" } , txnTieKnot $ Transaction { tdate=parsedate "2008/06/03", tdate2=Nothing, tstatus=True, tcode="", tdescription="eat & shop", tcomment="", ttags=[], tpostings=["expenses:food" `post` usd 1 ,"expenses:supplies" `post` usd 1 ,"assets:cash" `post` missingamt ], tpreceding_comment_lines="" } , txnTieKnot $ Transaction { tdate=parsedate "2008/12/31", tdate2=Nothing, tstatus=False, tcode="", tdescription="pay off", tcomment="", ttags=[], tpostings=["liabilities:debts" `post` usd 1 ,"assets:bank:checking" `post` usd (-1) ], tpreceding_comment_lines="" } ] } tests_Hledger_Data_Journal = TestList $ [ -- "query standard account types" ~: -- do -- let j = journal1 -- journalBalanceSheetAccountNames j `is` ["assets","assets:a","equity","equity:q","equity:q:qq","liabilities","liabilities:l"] -- journalProfitAndLossAccountNames j `is` ["expenses","expenses:e","income","income:i"] ] hledger-lib-0.22/Hledger/Data/Account.hs0000644000000000000000000001306312252750510016156 0ustar0000000000000000{-# LANGUAGE RecordWildCards, StandaloneDeriving #-} {-| An 'Account' has a name, a list of subaccounts, an optional parent account, and subaccounting-excluding and -including balances. -} module Hledger.Data.Account where import Data.List import qualified Data.Map as M import Safe (headMay, lookupJustDef) import Test.HUnit import Text.Printf import Hledger.Data.AccountName import Hledger.Data.Amount import Hledger.Data.Posting() import Hledger.Data.Types import Hledger.Utils -- deriving instance Show Account instance Show Account where show Account{..} = printf "Account %s (boring:%s, ebalance:%s, ibalance:%s)" aname (if aboring then "y" else "n" :: String) (showMixedAmount aebalance) (showMixedAmount aibalance) instance Eq Account where (==) a b = aname a == aname b -- quick equality test for speed -- and -- [ aname a == aname b -- -- , aparent a == aparent b -- avoid infinite recursion -- , asubs a == asubs b -- , aebalance a == aebalance b -- , aibalance a == aibalance b -- ] nullacct = Account { aname = "" , aparent = Nothing , asubs = [] , aebalance = nullmixedamt , aibalance = nullmixedamt , aboring = False } -- | Derive 1. an account tree and 2. their balances from a list of postings. -- (ledger's core feature). The accounts are returned in a list, but -- retain their tree structure; the first one is the root of the tree. accountsFromPostings :: [Posting] -> [Account] accountsFromPostings ps = let acctamts = [(paccount p,pamount p) | p <- ps] grouped = groupBy (\a b -> fst a == fst b) $ sort $ acctamts summed = map (\as@((aname,_):_) -> (aname, sum $ map snd as)) grouped -- always non-empty nametree = treeFromPaths $ map (expandAccountName . fst) summed acctswithnames = nameTreeToAccount "root" nametree acctswithebals = mapAccounts setebalance acctswithnames where setebalance a = a{aebalance=lookupJustDef nullmixedamt (aname a) summed} acctswithibals = sumAccounts acctswithebals acctswithparents = tieAccountParents acctswithibals acctsflattened = flattenAccounts acctswithparents in acctsflattened -- | Convert an AccountName tree to an Account tree nameTreeToAccount :: AccountName -> FastTree AccountName -> Account nameTreeToAccount rootname (T m) = nullacct{ aname=rootname, asubs=map (uncurry nameTreeToAccount) $ M.assocs m } -- | Tie the knot so all subaccounts' parents are set correctly. tieAccountParents :: Account -> Account tieAccountParents = tie Nothing where tie parent a@Account{..} = a' where a' = a{aparent=parent, asubs=map (tie (Just a')) asubs} -- | Get this account's parent accounts, from the nearest up to the root. parentAccounts :: Account -> [Account] parentAccounts Account{aparent=Nothing} = [] parentAccounts Account{aparent=Just a} = a:parentAccounts a -- | List the accounts at each level of the account tree. accountsLevels :: Account -> [[Account]] accountsLevels = takeWhile (not . null) . iterate (concatMap asubs) . (:[]) -- | Map a (non-tree-structure-modifying) function over this and sub accounts. mapAccounts :: (Account -> Account) -> Account -> Account mapAccounts f a = f a{asubs = map (mapAccounts f) $ asubs a} -- | Is the predicate true on any of this account or its subaccounts ? anyAccounts :: (Account -> Bool) -> Account -> Bool anyAccounts p a | p a = True | otherwise = any (anyAccounts p) $ asubs a -- | Add subaccount-inclusive balances to an account tree. sumAccounts :: Account -> Account sumAccounts a | null $ asubs a = a{aibalance=aebalance a} | otherwise = a{aibalance=ibal, asubs=subs} where subs = map sumAccounts $ asubs a ibal = sum $ aebalance a : map aibalance subs -- | Remove all subaccounts below a certain depth. clipAccounts :: Int -> Account -> Account clipAccounts 0 a = a{asubs=[]} clipAccounts d a = a{asubs=subs} where subs = map (clipAccounts (d-1)) $ asubs a -- | Remove all leaf accounts and subtrees matching a predicate. pruneAccounts :: (Account -> Bool) -> Account -> Maybe Account pruneAccounts p = headMay . prune where prune a | null prunedsubs = if p a then [] else [a] | otherwise = [a{asubs=prunedsubs}] where prunedsubs = concatMap prune $ asubs a -- | Flatten an account tree into a list, which is sometimes -- convenient. Note since accounts link to their parents/subs, the -- account tree remains intact and can still be used. It's a tree/list! flattenAccounts :: Account -> [Account] flattenAccounts a = squish a [] where squish a as = a:Prelude.foldr squish as (asubs a) -- | Filter an account tree (to a list). filterAccounts :: (Account -> Bool) -> Account -> [Account] filterAccounts p a | p a = a : concatMap (filterAccounts p) (asubs a) | otherwise = concatMap (filterAccounts p) (asubs a) -- | Search an account list by name. lookupAccount :: AccountName -> [Account] -> Maybe Account lookupAccount a = find ((==a).aname) -- debug helpers printAccounts :: Account -> IO () printAccounts = putStrLn . showAccounts showAccounts = unlines . map showAccountDebug . flattenAccounts showAccountsBoringFlag = unlines . map (show . aboring) . flattenAccounts showAccountDebug a = printf "%-25s %4s %4s %s" (aname a) (showMixedAmount $ aebalance a) (showMixedAmount $ aibalance a) (if aboring a then "b" else " " :: String) tests_Hledger_Data_Account = TestList [ ] hledger-lib-0.22/Hledger/Data/AccountName.hs0000644000000000000000000001406712252750510016764 0ustar0000000000000000{-# LANGUAGE NoMonomorphismRestriction#-} {-| 'AccountName's are strings like @assets:cash:petty@, with multiple components separated by ':'. From a set of these we derive the account hierarchy. -} module Hledger.Data.AccountName where import Data.List import Data.Tree import Test.HUnit import Text.Printf import Hledger.Data.Types import Hledger.Utils -- change to use a different separator for nested accounts acctsepchar = ':' accountNameComponents :: AccountName -> [String] accountNameComponents = splitAtElement acctsepchar accountNameFromComponents :: [String] -> AccountName accountNameFromComponents = concat . intersperse [acctsepchar] accountLeafName :: AccountName -> String accountLeafName = last . accountNameComponents accountNameLevel :: AccountName -> Int accountNameLevel "" = 0 accountNameLevel a = length (filter (==acctsepchar) a) + 1 accountNameDrop :: Int -> AccountName -> AccountName accountNameDrop n = accountNameFromComponents . drop n . accountNameComponents -- | ["a:b:c","d:e"] -> ["a","a:b","a:b:c","d","d:e"] expandAccountNames :: [AccountName] -> [AccountName] expandAccountNames as = nub $ concatMap expandAccountName as -- | "a:b:c" -> ["a","a:b","a:b:c"] expandAccountName :: AccountName -> [AccountName] expandAccountName = map accountNameFromComponents . tail . inits . accountNameComponents -- | ["a:b:c","d:e"] -> ["a","d"] topAccountNames :: [AccountName] -> [AccountName] topAccountNames as = [a | a <- expandAccountNames as, accountNameLevel a == 1] parentAccountName :: AccountName -> AccountName parentAccountName = accountNameFromComponents . init . accountNameComponents parentAccountNames :: AccountName -> [AccountName] parentAccountNames a = parentAccountNames' $ parentAccountName a where parentAccountNames' "" = [] parentAccountNames' a = a : parentAccountNames' (parentAccountName a) isAccountNamePrefixOf :: AccountName -> AccountName -> Bool isAccountNamePrefixOf = isPrefixOf . (++ [acctsepchar]) isSubAccountNameOf :: AccountName -> AccountName -> Bool s `isSubAccountNameOf` p = (p `isAccountNamePrefixOf` s) && (accountNameLevel s == (accountNameLevel p + 1)) -- | From a list of account names, select those which are direct -- subaccounts of the given account name. subAccountNamesFrom :: [AccountName] -> AccountName -> [AccountName] subAccountNamesFrom accts a = filter (`isSubAccountNameOf` a) accts -- | Convert a list of account names to a tree. accountNameTreeFrom :: [AccountName] -> Tree AccountName accountNameTreeFrom accts = Node "root" (accounttreesfrom (topAccountNames accts)) where accounttreesfrom :: [AccountName] -> [Tree AccountName] accounttreesfrom [] = [] accounttreesfrom as = [Node a (accounttreesfrom $ subs a) | a <- as] subs = subAccountNamesFrom (expandAccountNames accts) nullaccountnametree = Node "root" [] -- | Elide an account name to fit in the specified width. -- From the ledger 2.6 news: -- -- @ -- What Ledger now does is that if an account name is too long, it will -- start abbreviating the first parts of the account name down to two -- letters in length. If this results in a string that is still too -- long, the front will be elided -- not the end. For example: -- -- Expenses:Cash ; OK, not too long -- Ex:Wednesday:Cash ; "Expenses" was abbreviated to fit -- Ex:We:Afternoon:Cash ; "Expenses" and "Wednesday" abbreviated -- ; Expenses:Wednesday:Afternoon:Lunch:Snack:Candy:Chocolate:Cash -- ..:Af:Lu:Sn:Ca:Ch:Cash ; Abbreviated and elided! -- @ elideAccountName :: Int -> AccountName -> AccountName elideAccountName width s = elideLeft width $ accountNameFromComponents $ elideparts width [] $ accountNameComponents s where elideparts :: Int -> [String] -> [String] -> [String] elideparts width done ss | length (accountNameFromComponents $ done++ss) <= width = done++ss | length ss > 1 = elideparts width (done++[take 2 $ head ss]) (tail ss) | otherwise = done++ss clipAccountName :: Int -> AccountName -> AccountName clipAccountName n = accountNameFromComponents . take n . accountNameComponents -- | Convert an account name to a regular expression matching it and its subaccounts. accountNameToAccountRegex :: String -> String accountNameToAccountRegex "" = "" accountNameToAccountRegex a = printf "^%s(:|$)" a -- | Convert an account name to a regular expression matching it but not its subaccounts. accountNameToAccountOnlyRegex :: String -> String accountNameToAccountOnlyRegex "" = "" accountNameToAccountOnlyRegex a = printf "^%s$" a -- | Convert an exact account-matching regular expression to a plain account name. accountRegexToAccountName :: String -> String accountRegexToAccountName = regexReplace "^\\^(.*?)\\(:\\|\\$\\)$" "\\1" -- | Does this string look like an exact account-matching regular expression ? isAccountRegex :: String -> Bool isAccountRegex s = take 1 s == "^" && (take 5 $ reverse s) == ")$|:(" tests_Hledger_Data_AccountName = TestList [ "accountNameTreeFrom" ~: do accountNameTreeFrom ["a"] `is` Node "root" [Node "a" []] accountNameTreeFrom ["a","b"] `is` Node "root" [Node "a" [], Node "b" []] accountNameTreeFrom ["a","a:b"] `is` Node "root" [Node "a" [Node "a:b" []]] accountNameTreeFrom ["a:b:c"] `is` Node "root" [Node "a" [Node "a:b" [Node "a:b:c" []]]] ,"expandAccountNames" ~: expandAccountNames ["assets:cash","assets:checking","expenses:vacation"] `is` ["assets","assets:cash","assets:checking","expenses","expenses:vacation"] ,"isAccountNamePrefixOf" ~: do "assets" `isAccountNamePrefixOf` "assets" `is` False "assets" `isAccountNamePrefixOf` "assets:bank" `is` True "assets" `isAccountNamePrefixOf` "assets:bank:checking" `is` True "my assets" `isAccountNamePrefixOf` "assets:bank" `is` False ,"isSubAccountNameOf" ~: do "assets" `isSubAccountNameOf` "assets" `is` False "assets:bank" `isSubAccountNameOf` "assets" `is` True "assets:bank:checking" `isSubAccountNameOf` "assets" `is` False "assets:bank" `isSubAccountNameOf` "my assets" `is` False ] hledger-lib-0.22/Hledger/Data/Transaction.hs0000644000000000000000000006021212252750510017045 0ustar0000000000000000{-| A 'Transaction' represents a movement of some commodity(ies) between two or more accounts. It consists of multiple account 'Posting's which balance to zero, a date, and optional extras like description, cleared status, and tags. -} module Hledger.Data.Transaction ( -- * Transaction nulltransaction, txnTieKnot, -- settxn, -- * operations showAccountName, hasRealPostings, realPostings, virtualPostings, balancedVirtualPostings, transactionsPostings, isTransactionBalanced, -- nonzerobalanceerror, -- * date operations transactionDate2, -- * arithmetic transactionPostingBalances, balanceTransaction, -- * rendering showTransaction, showTransactionUnelided, -- * misc. tests_Hledger_Data_Transaction ) where import Data.List import Data.Maybe import Data.Time.Calendar import Test.HUnit import Text.Printf import qualified Data.Map as Map import Hledger.Utils import Hledger.Data.Types import Hledger.Data.Dates import Hledger.Data.Posting import Hledger.Data.Amount instance Show Transaction where show = showTransactionUnelided instance Show ModifierTransaction where show t = "= " ++ mtvalueexpr t ++ "\n" ++ unlines (map show (mtpostings t)) instance Show PeriodicTransaction where show t = "~ " ++ ptperiodicexpr t ++ "\n" ++ unlines (map show (ptpostings t)) nulltransaction :: Transaction nulltransaction = Transaction { tdate=nulldate, tdate2=Nothing, tstatus=False, tcode="", tdescription="", tcomment="", ttags=[], tpostings=[], tpreceding_comment_lines="" } {-| Show a journal transaction, formatted for the print command. ledger 2.x's standard format looks like this: @ yyyy/mm/dd[ *][ CODE] description......... [ ; comment...............] account name 1..................... ...$amount1[ ; comment...............] account name 2..................... ..$-amount1[ ; comment...............] pcodewidth = no limit -- 10 -- mimicking ledger layout. pdescwidth = no limit -- 20 -- I don't remember what these mean, pacctwidth = 35 minimum, no maximum -- they were important at the time. pamtwidth = 11 pcommentwidth = no limit -- 22 @ -} showTransaction :: Transaction -> String showTransaction = showTransaction' True showTransactionUnelided :: Transaction -> String showTransactionUnelided = showTransaction' False tests_showTransactionUnelided = [ "showTransactionUnelided" ~: do let t `gives` s = assertEqual "" s (showTransactionUnelided t) nulltransaction `gives` "0000/01/01\n\n" nulltransaction{ tdate=parsedate "2012/05/14", tdate2=Just $ parsedate "2012/05/15", tstatus=False, tcode="code", tdescription="desc", tcomment="tcomment1\ntcomment2\n", ttags=[("ttag1","val1")], tpostings=[ nullposting{ pstatus=True, paccount="a", pamount=Mixed [usd 1, hrs 2], pcomment="\npcomment2\n", ptype=RegularPosting, ptags=[("ptag1","val1"),("ptag2","val2")] } ] } `gives` unlines [ "2012/05/14=2012/05/15 (code) desc ; tcomment1", " ; tcomment2", " $1.00", " * a 2.0h", " ; pcomment2", "" ] ] -- XXX overlaps showPosting showTransaction' :: Bool -> Transaction -> String showTransaction' elide t = unlines $ [descriptionline] ++ newlinecomments ++ (postingsAsLines elide t (tpostings t)) ++ [""] where descriptionline = rstrip $ concat [date, status, code, desc, samelinecomment] date = showdate (tdate t) ++ maybe "" showedate (tdate2 t) showdate = printf "%-10s" . showDate showedate = printf "=%s" . showdate status = if tstatus t then " *" else "" code = if length (tcode t) > 0 then printf " (%s)" $ tcode t else "" desc = if null d then "" else " " ++ d where d = tdescription t (samelinecomment, newlinecomments) = case renderCommentLines (tcomment t) of [] -> ("",[]) c:cs -> (c,cs) -- Render a transaction or posting's comment as indented, semicolon-prefixed comment lines. renderCommentLines :: String -> [String] renderCommentLines s = case lines s of ("":ls) -> "":map commentprefix ls ls -> map commentprefix ls where commentprefix = indent . ("; "++) -- -- Render a transaction or posting's comment as semicolon-prefixed comment lines - -- -- an inline (same-line) comment if it's a single line, otherwise multiple indented lines. -- commentLines' :: String -> (String, [String]) -- commentLines' s -- | null s = ("", []) -- | length ls == 1 = (prefix $ head ls, []) -- | otherwise = ("", (prefix $ head ls):(map prefix $ tail ls)) -- where -- ls = lines s -- prefix = indent . (";"++) postingsAsLines :: Bool -> Transaction -> [Posting] -> [String] postingsAsLines elide t ps | elide && length ps > 1 && isTransactionBalanced Nothing t -- imprecise balanced check = (concatMap (postingAsLines False ps) $ init ps) ++ postingAsLines True ps (last ps) | otherwise = concatMap (postingAsLines False ps) ps postingAsLines :: Bool -> [Posting] -> Posting -> [String] postingAsLines elideamount ps p = postinglines ++ newlinecomments where postinglines = map rstrip $ lines $ concatTopPadded [showacct p, " ", amount, samelinecomment] amount = if elideamount then "" else showamt (pamount p) (samelinecomment, newlinecomments) = case renderCommentLines (pcomment p) of [] -> ("",[]) c:cs -> (c,cs) showacct p = indent $ showstatus p ++ printf (printf "%%-%ds" w) (showAccountName Nothing (ptype p) (paccount p)) where showstatus p = if pstatus p then "* " else "" w = maximum $ map (length . paccount) ps showamt = padleft 12 . showMixedAmount tests_postingAsLines = [ "postingAsLines" ~: do let p `gives` ls = assertEqual "" ls (postingAsLines False [p] p) posting `gives` [" 0"] posting{ pstatus=True, paccount="a", pamount=Mixed [usd 1, hrs 2], pcomment="pcomment1\npcomment2\n tag3: val3 \n", ptype=RegularPosting, ptags=[("ptag1","val1"),("ptag2","val2")] } `gives` [ " $1.00", " * a 2.0h ; pcomment1", " ; pcomment2", " ; tag3: val3 " ] ] indent :: String -> String indent = (" "++) -- | Show an account name, clipped to the given width if any, and -- appropriately bracketed/parenthesised for the given posting type. showAccountName :: Maybe Int -> PostingType -> AccountName -> String showAccountName w = fmt where fmt RegularPosting = take w' fmt VirtualPosting = parenthesise . reverse . take (w'-2) . reverse fmt BalancedVirtualPosting = bracket . reverse . take (w'-2) . reverse w' = fromMaybe 999999 w parenthesise s = "("++s++")" bracket s = "["++s++"]" hasRealPostings :: Transaction -> Bool hasRealPostings = not . null . realPostings realPostings :: Transaction -> [Posting] realPostings = filter isReal . tpostings virtualPostings :: Transaction -> [Posting] virtualPostings = filter isVirtual . tpostings balancedVirtualPostings :: Transaction -> [Posting] balancedVirtualPostings = filter isBalancedVirtual . tpostings transactionsPostings :: [Transaction] -> [Posting] transactionsPostings = concat . map tpostings -- | Get the sums of a transaction's real, virtual, and balanced virtual postings. transactionPostingBalances :: Transaction -> (MixedAmount,MixedAmount,MixedAmount) transactionPostingBalances t = (sumPostings $ realPostings t ,sumPostings $ virtualPostings t ,sumPostings $ balancedVirtualPostings t) -- | Is this transaction balanced ? A balanced transaction's real -- (non-virtual) postings sum to 0, and any balanced virtual postings -- also sum to 0. isTransactionBalanced :: Maybe (Map.Map Commodity AmountStyle) -> Transaction -> Bool isTransactionBalanced styles t = -- isReallyZeroMixedAmountCost rsum && isReallyZeroMixedAmountCost bvsum isZeroMixedAmount rsum' && isZeroMixedAmount bvsum' where (rsum, _, bvsum) = transactionPostingBalances t rsum' = canonicalise $ costOfMixedAmount rsum bvsum' = canonicalise $ costOfMixedAmount bvsum canonicalise = maybe id canonicaliseMixedAmount styles -- | Ensure this transaction is balanced, possibly inferring a missing -- amount or conversion price, or return an error message. -- -- Balancing is affected by commodity display precisions, so those may -- be provided. -- -- We can infer a missing real amount when there are multiple real -- postings and exactly one of them is amountless (likewise for -- balanced virtual postings). Inferred amounts are converted to cost -- basis when possible. -- -- We can infer a conversion price when all real amounts are specified -- and the sum of real postings' amounts is exactly two -- non-explicitly-priced amounts in different commodities (likewise -- for balanced virtual postings). balanceTransaction :: Maybe (Map.Map Commodity AmountStyle) -> Transaction -> Either String Transaction balanceTransaction styles t@Transaction{tpostings=ps} | length rwithoutamounts > 1 || length bvwithoutamounts > 1 = Left $ printerr "could not balance this transaction (too many missing amounts)" | not $ isTransactionBalanced styles t''' = Left $ printerr $ nonzerobalanceerror t''' | otherwise = Right t'''' where -- maybe infer missing amounts (rwithamounts, rwithoutamounts) = partition hasAmount $ realPostings t (bvwithamounts, bvwithoutamounts) = partition hasAmount $ balancedVirtualPostings t ramounts = map pamount rwithamounts bvamounts = map pamount bvwithamounts t' = t{tpostings=map inferamount ps} where inferamount p | not (hasAmount p) && isReal p = p{pamount = costOfMixedAmount (- sum ramounts)} | not (hasAmount p) && isBalancedVirtual p = p{pamount = costOfMixedAmount (- sum bvamounts)} | otherwise = p -- maybe infer conversion prices, for real postings rmixedamountsinorder = map pamount $ realPostings t' ramountsinorder = concatMap amounts rmixedamountsinorder rcommoditiesinorder = map acommodity ramountsinorder rsumamounts = amounts $ sum rmixedamountsinorder -- assumption: the sum of mixed amounts is normalised (one simple amount per commodity) t'' = if length rsumamounts == 2 && all ((==NoPrice).aprice) rsumamounts && t'==t then t'{tpostings=map inferprice ps} else t' where -- assumption: a posting's mixed amount contains one simple amount inferprice p@Posting{pamount=Mixed [a@Amount{acommodity=c,aprice=NoPrice}], ptype=RegularPosting} = p{pamount=Mixed [a{aprice=conversionprice c}]} where conversionprice c | c == unpricedcommodity -- assign a balancing price. Use @@ for more exact output when possible. -- invariant: prices should always be positive. Enforced with "abs" = if length ramountsinunpricedcommodity == 1 then TotalPrice $ abs targetcommodityamount `withPrecision` maxprecision else UnitPrice $ abs (targetcommodityamount `divideAmount` (aquantity unpricedamount)) `withPrecision` maxprecision | otherwise = NoPrice where unpricedcommodity = head $ filter (`elem` (map acommodity rsumamounts)) rcommoditiesinorder unpricedamount = head $ filter ((==unpricedcommodity).acommodity) rsumamounts targetcommodityamount = head $ filter ((/=unpricedcommodity).acommodity) rsumamounts ramountsinunpricedcommodity = filter ((==unpricedcommodity).acommodity) ramountsinorder inferprice p = p -- maybe infer prices for balanced virtual postings. Just duplicates the above for now. bvmixedamountsinorder = map pamount $ balancedVirtualPostings t'' bvamountsinorder = concatMap amounts bvmixedamountsinorder bvcommoditiesinorder = map acommodity bvamountsinorder bvsumamounts = amounts $ sum bvmixedamountsinorder t''' = if length bvsumamounts == 2 && all ((==NoPrice).aprice) bvsumamounts && t'==t -- XXX could check specifically for bv amount inferring then t''{tpostings=map inferprice ps} else t'' where inferprice p@Posting{pamount=Mixed [a@Amount{acommodity=c,aprice=NoPrice}], ptype=BalancedVirtualPosting} = p{pamount=Mixed [a{aprice=conversionprice c}]} where conversionprice c | c == unpricedcommodity = if length bvamountsinunpricedcommodity == 1 then TotalPrice $ abs targetcommodityamount `withPrecision` maxprecision else UnitPrice $ abs (targetcommodityamount `divideAmount` (aquantity unpricedamount)) `withPrecision` maxprecision | otherwise = NoPrice where unpricedcommodity = head $ filter (`elem` (map acommodity bvsumamounts)) bvcommoditiesinorder unpricedamount = head $ filter ((==unpricedcommodity).acommodity) bvsumamounts targetcommodityamount = head $ filter ((/=unpricedcommodity).acommodity) bvsumamounts bvamountsinunpricedcommodity = filter ((==unpricedcommodity).acommodity) bvamountsinorder inferprice p = p -- tie the knot so eg relatedPostings works right t'''' = txnTieKnot t''' printerr s = intercalate "\n" [s, showTransactionUnelided t] nonzerobalanceerror :: Transaction -> String nonzerobalanceerror t = printf "could not balance this transaction (%s%s%s)" rmsg sep bvmsg where (rsum, _, bvsum) = transactionPostingBalances t rmsg | isReallyZeroMixedAmountCost rsum = "" | otherwise = "real postings are off by " ++ showMixedAmount (costOfMixedAmount rsum) bvmsg | isReallyZeroMixedAmountCost bvsum = "" | otherwise = "balanced virtual postings are off by " ++ showMixedAmount (costOfMixedAmount bvsum) sep = if not (null rmsg) && not (null bvmsg) then "; " else "" :: String -- Get a transaction's secondary date, defaulting to the primary date. transactionDate2 :: Transaction -> Day transactionDate2 t = fromMaybe (tdate t) $ tdate2 t -- | Ensure a transaction's postings refer back to it. txnTieKnot :: Transaction -> Transaction txnTieKnot t@Transaction{tpostings=ps} = t{tpostings=map (settxn t) ps} -- | Set a posting's parent transaction. settxn :: Transaction -> Posting -> Posting settxn t p = p{ptransaction=Just t} tests_Hledger_Data_Transaction = TestList $ concat [ tests_postingAsLines, tests_showTransactionUnelided, [ "showTransaction" ~: do assertEqual "show a balanced transaction, eliding last amount" (unlines ["2007/01/28 coopportunity" ," expenses:food:groceries $47.18" ," assets:checking" ,"" ]) (let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" [] [posting{paccount="expenses:food:groceries", pamount=Mixed [usd 47.18], ptransaction=Just t} ,posting{paccount="assets:checking", pamount=Mixed [usd (-47.18)], ptransaction=Just t} ] "" in showTransaction t) ,"showTransaction" ~: do assertEqual "show a balanced transaction, no eliding" (unlines ["2007/01/28 coopportunity" ," expenses:food:groceries $47.18" ," assets:checking $-47.18" ,"" ]) (let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" [] [posting{paccount="expenses:food:groceries", pamount=Mixed [usd 47.18], ptransaction=Just t} ,posting{paccount="assets:checking", pamount=Mixed [usd (-47.18)], ptransaction=Just t} ] "" in showTransactionUnelided t) -- document some cases that arise in debug/testing: ,"showTransaction" ~: do assertEqual "show an unbalanced transaction, should not elide" (unlines ["2007/01/28 coopportunity" ," expenses:food:groceries $47.18" ," assets:checking $-47.19" ,"" ]) (showTransaction (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" [] [posting{paccount="expenses:food:groceries", pamount=Mixed [usd 47.18]} ,posting{paccount="assets:checking", pamount=Mixed [usd (-47.19)]} ] "")) ,"showTransaction" ~: do assertEqual "show an unbalanced transaction with one posting, should not elide" (unlines ["2007/01/28 coopportunity" ," expenses:food:groceries $47.18" ,"" ]) (showTransaction (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" [] [posting{paccount="expenses:food:groceries", pamount=Mixed [usd 47.18]} ] "")) ,"showTransaction" ~: do assertEqual "show a transaction with one posting and a missing amount" (unlines ["2007/01/28 coopportunity" ," expenses:food:groceries" ,"" ]) (showTransaction (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" [] [posting{paccount="expenses:food:groceries", pamount=missingmixedamt} ] "")) ,"showTransaction" ~: do assertEqual "show a transaction with a priced commodityless amount" (unlines ["2010/01/01 x" ," a 1 @ $2" ," b" ,"" ]) (showTransaction (txnTieKnot $ Transaction (parsedate "2010/01/01") Nothing False "" "x" "" [] [posting{paccount="a", pamount=Mixed [num 1 `at` (usd 2 `withPrecision` 0)]} ,posting{paccount="b", pamount= missingmixedamt} ] "")) ,"balanceTransaction" ~: do assertBool "detect unbalanced entry, sign error" (isLeft $ balanceTransaction Nothing (Transaction (parsedate "2007/01/28") Nothing False "" "test" "" [] [posting{paccount="a", pamount=Mixed [usd 1]} ,posting{paccount="b", pamount=Mixed [usd 1]} ] "")) assertBool "detect unbalanced entry, multiple missing amounts" (isLeft $ balanceTransaction Nothing (Transaction (parsedate "2007/01/28") Nothing False "" "test" "" [] [posting{paccount="a", pamount=missingmixedamt} ,posting{paccount="b", pamount=missingmixedamt} ] "")) let e = balanceTransaction Nothing (Transaction (parsedate "2007/01/28") Nothing False "" "" "" [] [posting{paccount="a", pamount=Mixed [usd 1]} ,posting{paccount="b", pamount=missingmixedamt} ] "") assertBool "balanceTransaction allows one missing amount" (isRight e) assertEqual "balancing amount is inferred" (Mixed [usd (-1)]) (case e of Right e' -> (pamount $ last $ tpostings e') Left _ -> error' "should not happen") let e = balanceTransaction Nothing (Transaction (parsedate "2011/01/01") Nothing False "" "" "" [] [posting{paccount="a", pamount=Mixed [usd 1.35]} ,posting{paccount="b", pamount=Mixed [eur (-1)]} ] "") assertBool "balanceTransaction can infer conversion price" (isRight e) assertEqual "balancing conversion price is inferred" (Mixed [usd 1.35 @@ (eur 1 `withPrecision` maxprecision)]) (case e of Right e' -> (pamount $ head $ tpostings e') Left _ -> error' "should not happen") assertBool "balanceTransaction balances based on cost if there are unit prices" (isRight $ balanceTransaction Nothing (Transaction (parsedate "2011/01/01") Nothing False "" "" "" [] [posting{paccount="a", pamount=Mixed [usd 1 `at` eur 2]} ,posting{paccount="a", pamount=Mixed [usd (-2) `at` eur 1]} ] "")) assertBool "balanceTransaction balances based on cost if there are total prices" (isRight $ balanceTransaction Nothing (Transaction (parsedate "2011/01/01") Nothing False "" "" "" [] [posting{paccount="a", pamount=Mixed [usd 1 @@ eur 1]} ,posting{paccount="a", pamount=Mixed [usd (-2) @@ eur 1]} ] "")) ,"isTransactionBalanced" ~: do let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] [posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t} ,posting{paccount="c", pamount=Mixed [usd (-1.00)], ptransaction=Just t} ] "" assertBool "detect balanced" (isTransactionBalanced Nothing t) let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] [posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t} ,posting{paccount="c", pamount=Mixed [usd (-1.01)], ptransaction=Just t} ] "" assertBool "detect unbalanced" (not $ isTransactionBalanced Nothing t) let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] [posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t} ] "" assertBool "detect unbalanced, one posting" (not $ isTransactionBalanced Nothing t) let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] [posting{paccount="b", pamount=Mixed [usd 0], ptransaction=Just t} ] "" assertBool "one zero posting is considered balanced for now" (isTransactionBalanced Nothing t) let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] [posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t} ,posting{paccount="c", pamount=Mixed [usd (-1.00)], ptransaction=Just t} ,posting{paccount="d", pamount=Mixed [usd 100], ptype=VirtualPosting, ptransaction=Just t} ] "" assertBool "virtual postings don't need to balance" (isTransactionBalanced Nothing t) let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] [posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t} ,posting{paccount="c", pamount=Mixed [usd (-1.00)], ptransaction=Just t} ,posting{paccount="d", pamount=Mixed [usd 100], ptype=BalancedVirtualPosting, ptransaction=Just t} ] "" assertBool "balanced virtual postings need to balance among themselves" (not $ isTransactionBalanced Nothing t) let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" "" [] [posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t} ,posting{paccount="c", pamount=Mixed [usd (-1.00)], ptransaction=Just t} ,posting{paccount="d", pamount=Mixed [usd 100], ptype=BalancedVirtualPosting, ptransaction=Just t} ,posting{paccount="3", pamount=Mixed [usd (-100)], ptype=BalancedVirtualPosting, ptransaction=Just t} ] "" assertBool "balanced virtual postings need to balance among themselves (2)" (isTransactionBalanced Nothing t) ]] hledger-lib-0.22/Hledger/Data/TimeLog.hs0000644000000000000000000001235712252750510016127 0ustar0000000000000000{-| A 'TimeLogEntry' is a clock-in, clock-out, or other directive in a timelog file (see timeclock.el or the command-line version). These can be converted to 'Transactions' and queried like a ledger. -} module Hledger.Data.TimeLog where import Data.Maybe import Data.Time.Calendar import Data.Time.Clock import Data.Time.Format import Data.Time.LocalTime import System.Locale (defaultTimeLocale) import Test.HUnit import Text.Printf import Hledger.Utils import Hledger.Data.Types import Hledger.Data.Dates import Hledger.Data.Amount import Hledger.Data.Posting import Hledger.Data.Transaction instance Show TimeLogEntry where show t = printf "%s %s %s" (show $ tlcode t) (show $ tldatetime t) (tlcomment t) instance Show TimeLogCode where show SetBalance = "b" show SetRequiredHours = "h" show In = "i" show Out = "o" show FinalOut = "O" instance Read TimeLogCode where readsPrec _ ('b' : xs) = [(SetBalance, xs)] readsPrec _ ('h' : xs) = [(SetRequiredHours, xs)] readsPrec _ ('i' : xs) = [(In, xs)] readsPrec _ ('o' : xs) = [(Out, xs)] readsPrec _ ('O' : xs) = [(FinalOut, xs)] readsPrec _ _ = [] -- | Convert time log entries to journal transactions. When there is no -- clockout, add one with the provided current time. Sessions crossing -- midnight are split into days to give accurate per-day totals. timeLogEntriesToTransactions :: LocalTime -> [TimeLogEntry] -> [Transaction] timeLogEntriesToTransactions _ [] = [] timeLogEntriesToTransactions now [i] | odate > idate = entryFromTimeLogInOut i o' : timeLogEntriesToTransactions now [i',o] | otherwise = [entryFromTimeLogInOut i o] where o = TimeLogEntry Out end "" end = if itime > now then itime else now (itime,otime) = (tldatetime i,tldatetime o) (idate,odate) = (localDay itime,localDay otime) o' = o{tldatetime=itime{localDay=idate, localTimeOfDay=TimeOfDay 23 59 59}} i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}} timeLogEntriesToTransactions now (i:o:rest) | odate > idate = entryFromTimeLogInOut i o' : timeLogEntriesToTransactions now (i':o:rest) | otherwise = entryFromTimeLogInOut i o : timeLogEntriesToTransactions now rest where (itime,otime) = (tldatetime i,tldatetime o) (idate,odate) = (localDay itime,localDay otime) o' = o{tldatetime=itime{localDay=idate, localTimeOfDay=TimeOfDay 23 59 59}} i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}} -- | Convert a timelog clockin and clockout entry to an equivalent journal -- transaction, representing the time expenditure. Note this entry is not balanced, -- since we omit the \"assets:time\" transaction for simpler output. entryFromTimeLogInOut :: TimeLogEntry -> TimeLogEntry -> Transaction entryFromTimeLogInOut i o | otime >= itime = t | otherwise = error' $ "clock-out time less than clock-in time in:\n" ++ showTransaction t where t = Transaction { tdate = idate, tdate2 = Nothing, tstatus = True, tcode = "", tdescription = showtime itod ++ "-" ++ showtime otod, tcomment = "", ttags = [], tpostings = ps, tpreceding_comment_lines="" } showtime = take 5 . show acctname = tlcomment i itime = tldatetime i otime = tldatetime o itod = localTimeOfDay itime otod = localTimeOfDay otime idate = localDay itime hours = elapsedSeconds (toutc otime) (toutc itime) / 3600 where toutc = localTimeToUTC utc amount = Mixed [hrs hours] ps = [posting{paccount=acctname, pamount=amount, ptype=VirtualPosting, ptransaction=Just t}] tests_Hledger_Data_TimeLog = TestList [ "timeLogEntriesToTransactions" ~: do today <- getCurrentDay now' <- getCurrentTime tz <- getCurrentTimeZone let now = utcToLocalTime tz now' nowstr = showtime now yesterday = prevday today clockin = TimeLogEntry In mktime d = LocalTime d . fromMaybe midnight . parseTime defaultTimeLocale "%H:%M:%S" showtime = formatTime defaultTimeLocale "%H:%M" assertEntriesGiveStrings name es ss = assertEqual name ss (map tdescription $ timeLogEntriesToTransactions now es) assertEntriesGiveStrings "started yesterday, split session at midnight" [clockin (mktime yesterday "23:00:00") ""] ["23:00-23:59","00:00-"++nowstr] assertEntriesGiveStrings "split multi-day sessions at each midnight" [clockin (mktime (addDays (-2) today) "23:00:00") ""] ["23:00-23:59","00:00-23:59","00:00-"++nowstr] assertEntriesGiveStrings "auto-clock-out if needed" [clockin (mktime today "00:00:00") ""] ["00:00-"++nowstr] let future = utcToLocalTime tz $ addUTCTime 100 now' futurestr = showtime future assertEntriesGiveStrings "use the clockin time for auto-clockout if it's in the future" [clockin future ""] [printf "%s-%s" futurestr futurestr] ]hledger-lib-0.22/Hledger/Data/Amount.hs0000644000000000000000000005621712252750510016035 0ustar0000000000000000{-# LANGUAGE StandaloneDeriving, RecordWildCards #-} {-| A simple 'Amount' is some quantity of money, shares, or anything else. It has a (possibly null) 'Commodity' and a numeric quantity: @ $1 £-50 EUR 3.44 GOOG 500 1.5h 90 apples 0 @ It may also have an assigned 'Price', representing this amount's per-unit or total cost in a different commodity. If present, this is rendered like so: @ EUR 2 \@ $1.50 (unit price) EUR 2 \@\@ $3 (total price) @ A 'MixedAmount' is zero or more simple amounts, so can represent multiple commodities; this is the type most often used: @ 0 $50 + EUR 3 16h + $13.55 + AAPL 500 + 6 oranges @ When a mixed amount has been \"normalised\", it has no more than one amount in each commodity and no zero amounts; or it has just a single zero amount and no others. Limited arithmetic with simple and mixed amounts is supported, best used with similar amounts since it mostly ignores assigned prices and commodity exchange rates. -} module Hledger.Data.Amount ( -- * Amount amount, nullamt, missingamt, num, usd, eur, gbp, hrs, at, (@@), amountWithCommodity, -- ** arithmetic costOfAmount, divideAmount, sumAmounts, -- ** rendering amountstyle, showAmount, showAmountDebug, showAmountWithoutPrice, maxprecision, maxprecisionwithpoint, setAmountPrecision, withPrecision, canonicaliseAmount, canonicalStyles, -- * MixedAmount nullmixedamt, missingmixedamt, mixed, amounts, normaliseMixedAmountPreservingFirstPrice, normaliseMixedAmountPreservingPrices, -- ** arithmetic costOfMixedAmount, divideMixedAmount, isNegativeMixedAmount, isZeroMixedAmount, isReallyZeroMixedAmount, isReallyZeroMixedAmountCost, -- ** rendering showMixedAmount, showMixedAmountDebug, showMixedAmountWithoutPrice, showMixedAmountWithPrecision, setMixedAmountPrecision, canonicaliseMixedAmount, -- * misc. ltraceamount, tests_Hledger_Data_Amount ) where import Data.Char (isDigit) import Data.List import Data.Map (findWithDefault) import Data.Ord (comparing) import Test.HUnit import Text.Printf import qualified Data.Map as M import Hledger.Data.Types import Hledger.Data.Commodity import Hledger.Utils deriving instance Show HistoricalPrice amountstyle = AmountStyle L False 0 '.' ',' [] ------------------------------------------------------------------------------- -- Amount instance Show Amount where show _a@Amount{..} -- debugLevel < 3 = showAmountWithoutPrice a -- debugLevel < 6 = showAmount a | debugLevel < 9 = printf "Amount {acommodity=%s, aquantity=%s, ..}" (show acommodity) (show aquantity) | otherwise = --showAmountDebug a printf "Amount {acommodity=%s, aquantity=%s, aprice=%s, astyle=%s}" (show acommodity) (show aquantity) (showPriceDebug aprice) (show astyle) instance Num Amount where abs a@Amount{aquantity=q} = a{aquantity=abs q} signum a@Amount{aquantity=q} = a{aquantity=signum q} fromInteger i = nullamt{aquantity=fromInteger i} negate a@Amount{aquantity=q} = a{aquantity=(-q)} (+) = similarAmountsOp (+) (-) = similarAmountsOp (-) (*) = similarAmountsOp (*) -- | The empty simple amount. amount, nullamt :: Amount amount = Amount{acommodity="", aquantity=0, aprice=NoPrice, astyle=amountstyle} nullamt = amount -- handy amount constructors for tests num n = amount{acommodity="", aquantity=n} usd n = amount{acommodity="$", aquantity=n, astyle=amountstyle{asprecision=2}} eur n = amount{acommodity="€", aquantity=n, astyle=amountstyle{asprecision=2}} gbp n = amount{acommodity="£", aquantity=n, astyle=amountstyle{asprecision=2}} hrs n = amount{acommodity="h", aquantity=n, astyle=amountstyle{asprecision=1, ascommodityside=R}} -- | Apply a binary arithmetic operator to two amounts in the same -- commodity. Warning, as a kludge to support folds (eg sum) we assign -- the second's commodity to the first so the same commodity requirement -- is not checked. The highest precision of either amount is preserved in -- the result. Any prices are currently ignored and discarded. The display -- style is that of the first amount, with precision set to the highest of -- either amount. similarAmountsOp :: (Double -> Double -> Double) -> Amount -> Amount -> Amount similarAmountsOp op Amount{acommodity=_, aquantity=aq, astyle=AmountStyle{asprecision=ap}} Amount{acommodity=bc, aquantity=bq, astyle=bs@AmountStyle{asprecision=bp}} = -- trace ("a:"++showAmount a) $ trace ("b:"++showAmount b++"\n") $ tracewith (("=:"++).showAmount) amount{acommodity=bc, aquantity=aq `op` bq, astyle=bs{asprecision=max ap bp}} -- ac==bc = amount{acommodity=ac, aquantity=aq `op` bq, astyle=as{asprecision=max ap bp}} -- otherwise = error "tried to do simple arithmetic with amounts in different commodities" -- | Convert an amount to the specified commodity, ignoring and discarding -- any assigned prices and assuming an exchange rate of 1. amountWithCommodity :: Commodity -> Amount -> Amount amountWithCommodity c a = a{acommodity=c, aprice=NoPrice} -- | A more complete amount adding operation. sumAmounts :: [Amount] -> MixedAmount sumAmounts = normaliseMixedAmountPreservingPrices . Mixed -- | Set an amount's unit price. at :: Amount -> Amount -> Amount amt `at` priceamt = amt{aprice=UnitPrice priceamt} -- | Set an amount's total price. (@@) :: Amount -> Amount -> Amount amt @@ priceamt = amt{aprice=TotalPrice priceamt} tests_sumAmounts = [ "sumAmounts" ~: do -- when adding, we don't convert to the price commodity - just -- combine what amounts we can. -- amounts with same unit price sumAmounts [usd 1 `at` eur 1, usd 1 `at` eur 1] `is` Mixed [usd 2 `at` eur 1] -- amounts with different unit prices -- amounts with total prices sumAmounts [usd 1 @@ eur 1, usd 1 @@ eur 1] `is` Mixed [usd 1 @@ eur 1, usd 1 @@ eur 1] -- amounts with no, unit, and/or total prices ] -- | Convert an amount to the commodity of its assigned price, if any. Notes: -- -- - price amounts must be MixedAmounts with exactly one component Amount (or there will be a runtime error) -- -- - price amounts should be positive, though this is not currently enforced costOfAmount :: Amount -> Amount costOfAmount a@Amount{aquantity=q, aprice=price} = case price of NoPrice -> a UnitPrice p@Amount{aquantity=pq} -> p{aquantity=pq * q} TotalPrice p@Amount{aquantity=pq} -> p{aquantity=pq * signum q} -- | Divide an amount's quantity by a constant. divideAmount :: Amount -> Double -> Amount divideAmount a@Amount{aquantity=q} d = a{aquantity=q/d} -- | Is this amount negative ? The price is ignored. isNegativeAmount :: Amount -> Bool isNegativeAmount Amount{aquantity=q} = q < 0 digits = "123456789" :: String -- | Does this amount appear to be zero when displayed with its given precision ? isZeroAmount :: Amount -> Bool isZeroAmount a -- a==missingamt = False | otherwise = (null . filter (`elem` digits) . showAmountWithoutPriceOrCommodity) a -- | Is this amount "really" zero, regardless of the display precision ? -- Since we are using floating point, for now just test to some high precision. isReallyZeroAmount :: Amount -> Bool isReallyZeroAmount a -- a==missingamt = False | otherwise = (null . filter (`elem` digits) . printf ("%."++show zeroprecision++"f") . aquantity) a where zeroprecision = 8 -- | Get the string representation of an amount, based on its commodity's -- display settings except using the specified precision. showAmountWithPrecision :: Int -> Amount -> String showAmountWithPrecision p = showAmount . setAmountPrecision p -- | Set an amount's display precision. setAmountPrecision :: Int -> Amount -> Amount setAmountPrecision p a@Amount{astyle=s} = a{astyle=s{asprecision=p}} -- | Set an amount's display precision, flipped. withPrecision :: Amount -> Int -> Amount withPrecision = flip setAmountPrecision -- | Get a string representation of an amount for debugging, -- appropriate to the current debug level. 9 shows maximum detail. showAmountDebug :: Amount -> String showAmountDebug Amount{acommodity="AUTO"} = "(missing)" showAmountDebug Amount{..} = printf "Amount {acommodity=%s, aquantity=%s, aprice=%s, astyle=%s}" (show acommodity) (show aquantity) (showPriceDebug aprice) (show astyle) -- | Get the string representation of an amount, without any \@ price. showAmountWithoutPrice :: Amount -> String showAmountWithoutPrice a = showAmount a{aprice=NoPrice} -- | Get the string representation of an amount, without any price or commodity symbol. showAmountWithoutPriceOrCommodity :: Amount -> String showAmountWithoutPriceOrCommodity a = showAmount a{acommodity="", aprice=NoPrice} showPrice :: Price -> String showPrice NoPrice = "" showPrice (UnitPrice pa) = " @ " ++ showAmount pa showPrice (TotalPrice pa) = " @@ " ++ showAmount pa showPriceDebug :: Price -> String showPriceDebug NoPrice = "" showPriceDebug (UnitPrice pa) = " @ " ++ showAmountDebug pa showPriceDebug (TotalPrice pa) = " @@ " ++ showAmountDebug pa -- | Get the string representation of an amount, based on its commodity's -- display settings. String representations equivalent to zero are -- converted to just \"0\". showAmount :: Amount -> String showAmount Amount{acommodity="AUTO"} = "" showAmount a@(Amount{acommodity=c, aprice=p, astyle=AmountStyle{..}}) = case ascommodityside of L -> printf "%s%s%s%s" c' space quantity' price R -> printf "%s%s%s%s" quantity' space c' price where quantity = showamountquantity a displayingzero = null $ filter (`elem` digits) $ quantity (quantity',c') | displayingzero = ("0","") | otherwise = (quantity, quoteCommoditySymbolIfNeeded c) space = if (not (null c') && ascommodityspaced) then " " else "" :: String price = showPrice p -- | Get the string representation of the number part of of an amount, -- using the display settings from its commodity. showamountquantity :: Amount -> String showamountquantity Amount{aquantity=q, astyle=AmountStyle{asprecision=p, asdecimalpoint=d, asseparator=s, asseparatorpositions=spos}} = punctuatenumber d s spos $ qstr where -- isint n = fromIntegral (round n) == n qstr -- p == maxprecision && isint q = printf "%d" (round q::Integer) | p == maxprecisionwithpoint = printf "%f" q | p == maxprecision = chopdotzero $ printf "%f" q | otherwise = printf ("%."++show p++"f") q -- | Replace a number string's decimal point with the specified character, -- and add the specified digit group separators. The last digit group will -- be repeated as needed. punctuatenumber :: Char -> Char -> [Int] -> String -> String punctuatenumber dec sep grps str = sign ++ reverse (addseps sep (extend grps) (reverse int)) ++ frac'' where (sign,num) = break isDigit str (int,frac) = break (=='.') num frac' = dropWhile (=='.') frac frac'' | null frac' = "" | otherwise = dec:frac' extend [] = [] extend gs = init gs ++ repeat (last gs) addseps _ [] str = str addseps sep (g:gs) str | length str <= g = str | otherwise = let (s,rest) = splitAt g str in s ++ [sep] ++ addseps sep gs rest chopdotzero str = reverse $ case reverse str of '0':'.':s -> s s -> s -- | For rendering: a special precision value which means show all available digits. maxprecision :: Int maxprecision = 999998 -- | For rendering: a special precision value which forces display of a decimal point. maxprecisionwithpoint :: Int maxprecisionwithpoint = 999999 -- like journalCanonicaliseAmounts -- | Canonicalise an amount's display style using the provided commodity style map. canonicaliseAmount :: M.Map Commodity AmountStyle -> Amount -> Amount canonicaliseAmount styles a@Amount{acommodity=c, astyle=s} = a{astyle=s'} where s' = findWithDefault s c styles ------------------------------------------------------------------------------- -- MixedAmount instance Show MixedAmount where show -- debugLevel < 3 = intercalate "\\n" . lines . showMixedAmountWithoutPrice -- debugLevel < 6 = intercalate "\\n" . lines . showMixedAmount | otherwise = showMixedAmountDebug instance Num MixedAmount where fromInteger i = Mixed [fromInteger i] negate (Mixed as) = Mixed $ map negate as (+) (Mixed as) (Mixed bs) = normaliseMixedAmountPreservingPrices $ Mixed $ as ++ bs (*) = error' "programming error, mixed amounts do not support multiplication" abs = error' "programming error, mixed amounts do not support abs" signum = error' "programming error, mixed amounts do not support signum" -- | The empty mixed amount. nullmixedamt :: MixedAmount nullmixedamt = Mixed [] -- | A temporary value for parsed transactions which had no amount specified. missingamt :: Amount missingamt = amount{acommodity="AUTO"} missingmixedamt :: MixedAmount missingmixedamt = Mixed [missingamt] mixed :: Amount -> MixedAmount mixed a = Mixed [a] -- | Simplify a mixed amount's component amounts: we can combine amounts -- with the same commodity and unit price. Also remove any zero or missing -- amounts and replace an empty amount list with a single zero amount. normaliseMixedAmountPreservingPrices :: MixedAmount -> MixedAmount normaliseMixedAmountPreservingPrices (Mixed as) = Mixed as'' where as'' = if null nonzeros then [nullamt] else nonzeros (_,nonzeros) = partition isReallyZeroAmount as' as' = map sumAmountsUsingFirstPrice $ group $ sort $ filter (/= missingamt) as sort = sortBy (\a1 a2 -> compare (acommodity a1, aprice a1) (acommodity a2, aprice a2)) group = groupBy (\a1 a2 -> acommodity a1 == acommodity a2 && sameunitprice a1 a2) where sameunitprice a1 a2 = case (aprice a1, aprice a2) of (NoPrice, NoPrice) -> True (UnitPrice p1, UnitPrice p2) -> p1 == p2 _ -> False tests_normaliseMixedAmountPreservingPrices = [ "normaliseMixedAmountPreservingPrices" ~: do assertEqual "discard missing amount" (Mixed [nullamt]) (normaliseMixedAmountPreservingPrices $ Mixed [usd 0, missingamt]) assertEqual "combine unpriced same-commodity amounts" (Mixed [usd 2]) (normaliseMixedAmountPreservingPrices $ Mixed [usd 0, usd 2]) assertEqual "don't combine total-priced amounts" (Mixed [usd 1 @@ eur 1 ,usd (-2) @@ eur 1 ]) (normaliseMixedAmountPreservingPrices $ Mixed [usd 1 @@ eur 1 ,usd (-2) @@ eur 1 ]) ] -- | Simplify a mixed amount's component amounts: combine amounts with -- the same commodity, using the first amount's price for subsequent -- amounts in each commodity (ie, this function alters the amount and -- is best used as a rendering helper.). Also remove any zero amounts -- and replace an empty amount list with a single zero amount. normaliseMixedAmountPreservingFirstPrice :: MixedAmount -> MixedAmount normaliseMixedAmountPreservingFirstPrice (Mixed as) = Mixed as'' where as'' = if null nonzeros then [nullamt] else nonzeros (_,nonzeros) = partition (\a -> isReallyZeroAmount a && a /= missingamt) as' as' = map sumAmountsUsingFirstPrice $ group $ sort as sort = sortBy (\a1 a2 -> compare (acommodity a1) (acommodity a2)) group = groupBy (\a1 a2 -> acommodity a1 == acommodity a2) -- discardPrice :: Amount -> Amount -- discardPrice a = a{price=Nothing} -- discardPrices :: MixedAmount -> MixedAmount -- discardPrices (Mixed as) = Mixed $ map discardPrice as sumAmountsUsingFirstPrice [] = nullamt sumAmountsUsingFirstPrice as = (sum as){aprice=aprice $ head as} -- | Get a mixed amount's component amounts. amounts :: MixedAmount -> [Amount] amounts (Mixed as) = as -- | Convert a mixed amount's component amounts to the commodity of their -- assigned price, if any. costOfMixedAmount :: MixedAmount -> MixedAmount costOfMixedAmount (Mixed as) = Mixed $ map costOfAmount as -- | Divide a mixed amount's quantities by a constant. divideMixedAmount :: MixedAmount -> Double -> MixedAmount divideMixedAmount (Mixed as) d = Mixed $ map (flip divideAmount d) as -- | Is this mixed amount negative, if it can be normalised to a single commodity ? isNegativeMixedAmount :: MixedAmount -> Maybe Bool isNegativeMixedAmount m = case as of [a] -> Just $ isNegativeAmount a _ -> Nothing where as = amounts $ normaliseMixedAmountPreservingFirstPrice m -- | Does this mixed amount appear to be zero when displayed with its given precision ? isZeroMixedAmount :: MixedAmount -> Bool isZeroMixedAmount = all isZeroAmount . amounts . normaliseMixedAmountPreservingFirstPrice -- | Is this mixed amount "really" zero ? See isReallyZeroAmount. isReallyZeroMixedAmount :: MixedAmount -> Bool isReallyZeroMixedAmount = all isReallyZeroAmount . amounts . normaliseMixedAmountPreservingFirstPrice -- | Is this mixed amount "really" zero, after converting to cost -- commodities where possible ? isReallyZeroMixedAmountCost :: MixedAmount -> Bool isReallyZeroMixedAmountCost = isReallyZeroMixedAmount . costOfMixedAmount -- -- | MixedAmount derived Eq instance in Types.hs doesn't know that we -- -- want $0 = EUR0 = 0. Yet we don't want to drag all this code over there. -- -- For now, use this when cross-commodity zero equality is important. -- mixedAmountEquals :: MixedAmount -> MixedAmount -> Bool -- mixedAmountEquals a b = amounts a' == amounts b' || (isZeroMixedAmount a' && isZeroMixedAmount b') -- where a' = normaliseMixedAmountPreservingFirstPrice a -- b' = normaliseMixedAmountPreservingFirstPrice b -- | Get the string representation of a mixed amount, showing each of -- its component amounts. NB a mixed amount can have an empty amounts -- list in which case it shows as \"\". showMixedAmount :: MixedAmount -> String showMixedAmount m = vConcatRightAligned $ map showAmount $ amounts $ normaliseMixedAmountPreservingFirstPrice m -- | Compact labelled trace of a mixed amount, for debugging. ltraceamount :: String -> MixedAmount -> MixedAmount ltraceamount s = traceWith (((s ++ ": ") ++).showMixedAmount) -- | Set the display precision in the amount's commodities. setMixedAmountPrecision :: Int -> MixedAmount -> MixedAmount setMixedAmountPrecision p (Mixed as) = Mixed $ map (setAmountPrecision p) as -- | Get the string representation of a mixed amount, showing each of its -- component amounts with the specified precision, ignoring their -- commoditys' display precision settings. showMixedAmountWithPrecision :: Int -> MixedAmount -> String showMixedAmountWithPrecision p m = vConcatRightAligned $ map (showAmountWithPrecision p) $ amounts $ normaliseMixedAmountPreservingFirstPrice m -- | Get an unambiguous string representation of a mixed amount for debugging. showMixedAmountDebug :: MixedAmount -> String showMixedAmountDebug m | m == missingmixedamt = "(missing)" | otherwise = printf "Mixed [%s]" as where as = intercalate "\n " $ map showAmountDebug $ amounts m -- normaliseMixedAmountPreservingFirstPrice m -- | Get the string representation of a mixed amount, but without -- any \@ prices. showMixedAmountWithoutPrice :: MixedAmount -> String showMixedAmountWithoutPrice m = concat $ intersperse "\n" $ map showfixedwidth as where (Mixed as) = normaliseMixedAmountPreservingFirstPrice $ stripPrices m stripPrices (Mixed as) = Mixed $ map stripprice as where stripprice a = a{aprice=NoPrice} width = maximum $ map (length . showAmount) as showfixedwidth = printf (printf "%%%ds" width) . showAmountWithoutPrice -- | Canonicalise a mixed amount's display styles using the provided commodity style map. canonicaliseMixedAmount :: M.Map Commodity AmountStyle -> MixedAmount -> MixedAmount canonicaliseMixedAmount styles (Mixed as) = Mixed $ map (canonicaliseAmount styles) as -- | Given a list of amounts in parse order, build a map from commodities -- to canonical display styles for amounts in that commodity. canonicalStyles :: [Amount] -> M.Map Commodity AmountStyle canonicalStyles amts = M.fromList commstyles where samecomm = \a1 a2 -> acommodity a1 == acommodity a2 commamts = [(acommodity $ head as, as) | as <- groupBy samecomm $ sortBy (comparing acommodity) amts] commstyles = [(c, s) | (c,as) <- commamts , let styles = map astyle as , let maxprec = maximum $ map asprecision styles , let s = (head styles){asprecision=maxprec} ] -- lookupStyle :: M.Map Commodity AmountStyle -> Commodity -> AmountStyle -- lookupStyle ------------------------------------------------------------------------------- -- misc tests_Hledger_Data_Amount = TestList $ tests_normaliseMixedAmountPreservingPrices ++ tests_sumAmounts ++ [ -- Amount "costOfAmount" ~: do costOfAmount (eur 1) `is` eur 1 costOfAmount (eur 2){aprice=UnitPrice $ usd 2} `is` usd 4 costOfAmount (eur 1){aprice=TotalPrice $ usd 2} `is` usd 2 costOfAmount (eur (-1)){aprice=TotalPrice $ usd 2} `is` usd (-2) ,"isZeroAmount" ~: do assertBool "" $ isZeroAmount $ amount assertBool "" $ isZeroAmount $ usd 0 ,"negating amounts" ~: do let a = usd 1 negate a `is` a{aquantity=(-1)} let b = (usd 1){aprice=UnitPrice $ eur 2} negate b `is` b{aquantity=(-1)} ,"adding amounts without prices" ~: do let a1 = usd 1.23 let a2 = usd (-1.23) let a3 = usd (-1.23) (a1 + a2) `is` usd 0 (a1 + a3) `is` usd 0 (a2 + a3) `is` usd (-2.46) (a3 + a3) `is` usd (-2.46) sum [a1,a2,a3,-a3] `is` usd 0 -- highest precision is preserved let ap1 = usd 1 `withPrecision` 1 ap3 = usd 1 `withPrecision` 3 (asprecision $ astyle $ sum [ap1,ap3]) `is` 3 (asprecision $ astyle $ sum [ap3,ap1]) `is` 3 -- adding different commodities assumes conversion rate 1 assertBool "" $ isZeroAmount (a1 - eur 1.23) ,"showAmount" ~: do showAmount (usd 0 + gbp 0) `is` "0" -- MixedAmount ,"normaliseMixedAmountPreservingFirstPrice" ~: do normaliseMixedAmountPreservingFirstPrice (Mixed []) `is` Mixed [nullamt] assertBool "" $ isZeroMixedAmount $ normaliseMixedAmountPreservingFirstPrice (Mixed [usd 10 ,usd 10 @@ eur 7 ,usd (-10) ,usd (-10) @@ eur 7 ]) ,"adding mixed amounts" ~: do (sum $ map (Mixed . (\a -> [a])) [usd 1.25 ,usd (-1) `withPrecision` 0 ,usd (-0.25) ]) `is` Mixed [amount{aquantity=0}] ,"adding mixed amounts with total prices" ~: do (sum $ map (Mixed . (\a -> [a])) [usd 1 @@ eur 1 ,usd (-2) @@ eur 1 ]) `is` (Mixed [usd 1 @@ eur 1 ,usd (-2) @@ eur 1 ]) ,"showMixedAmount" ~: do showMixedAmount (Mixed [usd 1]) `is` "$1.00" showMixedAmount (Mixed [usd 1 `at` eur 2]) `is` "$1.00 @ €2.00" showMixedAmount (Mixed [usd 0]) `is` "0" showMixedAmount (Mixed []) `is` "0" showMixedAmount missingmixedamt `is` "" ,"showMixedAmountWithoutPrice" ~: do let a = usd 1 `at` eur 2 showMixedAmountWithoutPrice (Mixed [a]) `is` "$1.00" showMixedAmountWithoutPrice (Mixed [a, (-a)]) `is` "0" ] hledger-lib-0.22/Hledger/Data/Types.hs0000644000000000000000000002365612252750510015677 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} {-| Most data types are defined here to avoid import cycles. Here is an overview of the hledger data model: > Journal -- a journal is read from one or more data files. It contains.. > [Transaction] -- journal transactions (aka entries), which have date, status, code, description and.. > [Posting] -- multiple account postings, which have account name and amount > [HistoricalPrice] -- historical commodity prices > > Ledger -- a ledger is derived from a journal, by applying a filter specification and doing some further processing. It contains.. > Journal -- a filtered copy of the original journal, containing only the transactions and postings we are interested in > [Account] -- all accounts, in tree order beginning with a "root" account", with their balances and sub/parent accounts For more detailed documentation on each type, see the corresponding modules. -} module Hledger.Data.Types where import Control.Monad.Error (ErrorT) import Data.Data import qualified Data.Map as M import Data.Time.Calendar import Data.Time.LocalTime import System.Time (ClockTime(..)) type SmartDate = (String,String,String) data WhichDate = PrimaryDate | SecondaryDate deriving (Eq,Show) data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Show,Ord,Data,Typeable) data Interval = NoInterval | Days Int | Weeks Int | Months Int | Quarters Int | Years Int | DayOfMonth Int | DayOfWeek Int -- WeekOfYear Int | MonthOfYear Int | QuarterOfYear Int deriving (Eq,Show,Ord,Data,Typeable) type AccountName = String data Side = L | R deriving (Eq,Show,Read,Ord,Typeable,Data) type Commodity = String type Quantity = Double -- | An amount's price (none, per unit, or total) in another commodity. -- Note the price should be a positive number, although this is not enforced. data Price = NoPrice | UnitPrice Amount | TotalPrice Amount deriving (Eq,Ord,Typeable,Data) -- | Display style for an amount. data AmountStyle = AmountStyle { ascommodityside :: Side, -- ^ does the symbol appear on the left or the right ? ascommodityspaced :: Bool, -- ^ space between symbol and quantity ? asprecision :: Int, -- ^ number of digits displayed after the decimal point asdecimalpoint :: Char, -- ^ character used as decimal point asseparator :: Char, -- ^ character used for separating digit groups (eg thousands) asseparatorpositions :: [Int] -- ^ positions of digit group separators, counting leftward from decimal point } deriving (Eq,Ord,Read,Show,Typeable,Data) data Amount = Amount { acommodity :: Commodity, aquantity :: Quantity, aprice :: Price, -- ^ the (fixed) price for this amount, if any astyle :: AmountStyle } deriving (Eq,Ord,Typeable,Data) newtype MixedAmount = Mixed [Amount] deriving (Eq,Ord,Typeable,Data) data PostingType = RegularPosting | VirtualPosting | BalancedVirtualPosting deriving (Eq,Show,Typeable,Data) type Tag = (String, String) -- ^ A tag name and (possibly empty) value. data Posting = Posting { pdate :: Maybe Day, -- ^ this posting's date, if different from the transaction's pdate2 :: Maybe Day, -- ^ this posting's secondary date, if different from the transaction's pstatus :: Bool, paccount :: AccountName, pamount :: MixedAmount, pcomment :: String, -- ^ this posting's comment lines, as a single non-indented multi-line string ptype :: PostingType, ptags :: [Tag], -- ^ tag names and values, extracted from the comment pbalanceassertion :: Maybe MixedAmount, -- ^ optional: the expected balance in the account after this posting ptransaction :: Maybe Transaction -- ^ this posting's parent transaction (co-recursive types). -- Tying this knot gets tedious, Maybe makes it easier/optional. } deriving (Typeable,Data) -- The equality test for postings ignores the parent transaction's -- identity, to avoid infinite loops. instance Eq Posting where (==) (Posting a1 b1 c1 d1 e1 f1 g1 h1 i1 _) (Posting a2 b2 c2 d2 e2 f2 g2 h2 i2 _) = a1==a2 && b1==b2 && c1==c2 && d1==d2 && e1==e2 && f1==f2 && g1==g2 && h1==h2 && i1==i2 data Transaction = Transaction { tdate :: Day, tdate2 :: Maybe Day, tstatus :: Bool, -- XXX tcleared ? tcode :: String, tdescription :: String, tcomment :: String, -- ^ this transaction's comment lines, as a single non-indented multi-line string ttags :: [Tag], -- ^ tag names and values, extracted from the comment tpostings :: [Posting], -- ^ this transaction's postings tpreceding_comment_lines :: String -- ^ any comment lines immediately preceding this transaction } deriving (Eq,Typeable,Data) data ModifierTransaction = ModifierTransaction { mtvalueexpr :: String, mtpostings :: [Posting] } deriving (Eq,Typeable,Data) data PeriodicTransaction = PeriodicTransaction { ptperiodicexpr :: String, ptpostings :: [Posting] } deriving (Eq,Typeable,Data) data TimeLogCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord,Typeable,Data) data TimeLogEntry = TimeLogEntry { tlcode :: TimeLogCode, tldatetime :: LocalTime, tlcomment :: String } deriving (Eq,Ord,Typeable,Data) data HistoricalPrice = HistoricalPrice { hdate :: Day, hcommodity :: Commodity, hamount :: Amount } deriving (Eq,Typeable,Data) -- & Show (in Amount.hs) type Year = Integer -- | A journal "context" is some data which can change in the course of -- parsing a journal. An example is the default year, which changes when a -- Y directive is encountered. At the end of parsing, the final context -- is saved for later use by eg the add command. data JournalContext = Ctx { ctxYear :: !(Maybe Year) -- ^ the default year most recently specified with Y , ctxCommodityAndStyle :: !(Maybe (Commodity,AmountStyle)) -- ^ the default commodity and amount style most recently specified with D , ctxAccount :: ![AccountName] -- ^ the current stack of parent accounts/account name components -- specified with "account" directive(s). Concatenated, these -- are the account prefix prepended to parsed account names. , ctxAliases :: ![(AccountName,AccountName)] -- ^ the current list of account name aliases in effect } deriving (Read, Show, Eq, Data, Typeable) deriving instance Data (ClockTime) deriving instance Typeable (ClockTime) data Journal = Journal { jmodifiertxns :: [ModifierTransaction], jperiodictxns :: [PeriodicTransaction], jtxns :: [Transaction], open_timelog_entries :: [TimeLogEntry], historical_prices :: [HistoricalPrice], final_comment_lines :: String, -- ^ any trailing comments from the journal file jContext :: JournalContext, -- ^ the context (parse state) at the end of parsing files :: [(FilePath, String)], -- ^ the file path and raw text of the main and -- any included journal files. The main file is -- first followed by any included files in the -- order encountered (XXX reversed, cf journalAddFile). filereadtime :: ClockTime, -- ^ when this journal was last read from its file(s) jcommoditystyles :: M.Map Commodity AmountStyle -- ^ how to display amounts in each commodity } deriving (Eq, Typeable, Data) -- | A JournalUpdate is some transformation of a Journal. It can do I/O or -- raise an error. type JournalUpdate = ErrorT String IO (Journal -> Journal) -- | The id of a data format understood by hledger, eg @journal@ or @csv@. type Format = String -- | A hledger journal reader is a triple of format name, format-detecting -- predicate, and a parser to Journal. data Reader = Reader { -- name of the format this reader handles rFormat :: Format -- quickly check if this reader can probably handle the given file path and file content ,rDetector :: FilePath -> String -> Bool -- parse the given string, using the given parse rules file if any, returning a journal or error aware of the given file path ,rParser :: Maybe FilePath -> FilePath -> String -> ErrorT String IO Journal } instance Show Reader where show r = "Reader for "++rFormat r -- format strings data HledgerFormatField = AccountField | DefaultDateField | DescriptionField | TotalField | DepthSpacerField | FieldNo Int deriving (Show, Eq) data FormatString = FormatLiteral String | FormatField Bool -- Left justified ? (Maybe Int) -- Min width (Maybe Int) -- Max width HledgerFormatField -- Field deriving (Show, Eq) -- | An account, with name, balances and links to parent/subaccounts -- which let you walk up or down the account tree. data Account = Account { aname :: AccountName, -- ^ this account's full name aebalance :: MixedAmount, -- ^ this account's balance, excluding subaccounts asubs :: [Account], -- ^ sub-accounts -- anumpostings :: Int -- ^ number of postings to this account -- derived from the above: aibalance :: MixedAmount, -- ^ this account's balance, including subaccounts aparent :: Maybe Account, -- ^ parent account aboring :: Bool -- ^ used in the accounts report to label elidable parents } -- | A Ledger has the journal it derives from, and the accounts -- derived from that. Accounts are accessible both list-wise and -- tree-wise, since each one knows its parent and subs; the first -- account is the root of the tree and always exists. data Ledger = Ledger { ljournal :: Journal, laccounts :: [Account] } hledger-lib-0.22/Hledger/Data/Posting.hs0000644000000000000000000002042712252750510016207 0ustar0000000000000000{-| A 'Posting' represents a change (by some 'MixedAmount') of the balance in some 'Account'. Each 'Transaction' contains two or more postings which should add up to 0. Postings reference their parent transaction, so we can look up the date or description there. -} module Hledger.Data.Posting ( -- * Posting nullposting, posting, post, -- * operations postingCleared, isReal, isVirtual, isBalancedVirtual, isEmptyPosting, hasAmount, postingAllTags, transactionAllTags, relatedPostings, -- * date operations postingDate, postingDate2, isPostingInDateSpan, postingsDateSpan, -- * account name operations accountNamesFromPostings, accountNamePostingType, accountNameWithoutPostingType, accountNameWithPostingType, joinAccountNames, concatAccountNames, accountNameApplyAliases, -- * arithmetic sumPostings, -- * rendering showPosting, -- * misc. showComment, tests_Hledger_Data_Posting ) where import Data.List import Data.Maybe import Data.Ord import Data.Time.Calendar import Safe import Test.HUnit import Text.Printf import Hledger.Utils import Hledger.Data.Types import Hledger.Data.Amount import Hledger.Data.AccountName import Hledger.Data.Dates (nulldate, spanContainsDate) instance Show Posting where show = showPosting nullposting, posting :: Posting nullposting = Posting {pdate=Nothing ,pdate2=Nothing ,pstatus=False ,paccount="" ,pamount=nullmixedamt ,pcomment="" ,ptype=RegularPosting ,ptags=[] ,pbalanceassertion=Nothing ,ptransaction=Nothing } posting = nullposting post :: AccountName -> Amount -> Posting post acct amt = posting {paccount=acct, pamount=mixed amt} showPosting :: Posting -> String showPosting p@Posting{paccount=a,pamount=amt,ptype=t} = unlines $ [concatTopPadded [showaccountname a ++ " ", showamount amt, showComment (pcomment p)]] where ledger3ishlayout = False acctnamewidth = if ledger3ishlayout then 25 else 22 showaccountname = printf ("%-"++(show acctnamewidth)++"s") . bracket . elideAccountName width (bracket,width) = case t of BalancedVirtualPosting -> (\s -> "["++s++"]", acctnamewidth-2) VirtualPosting -> (\s -> "("++s++")", acctnamewidth-2) _ -> (id,acctnamewidth) showamount = padleft 12 . showMixedAmount showComment :: String -> String showComment s = if null s then "" else " ;" ++ s isReal :: Posting -> Bool isReal p = ptype p == RegularPosting isVirtual :: Posting -> Bool isVirtual p = ptype p == VirtualPosting isBalancedVirtual :: Posting -> Bool isBalancedVirtual p = ptype p == BalancedVirtualPosting hasAmount :: Posting -> Bool hasAmount = (/= missingmixedamt) . pamount accountNamesFromPostings :: [Posting] -> [AccountName] accountNamesFromPostings = nub . map paccount sumPostings :: [Posting] -> MixedAmount sumPostings = sum . map pamount -- | Get a posting's (primary) date - it's own primary date if specified, -- otherwise the parent transaction's primary date, or the null date if -- there is no parent transaction. postingDate :: Posting -> Day postingDate p = fromMaybe txndate $ pdate p where txndate = maybe nulldate tdate $ ptransaction p -- | Get a posting's secondary (secondary) date, which is the first of: -- posting's secondary date, transaction's secondary date, posting's -- primary date, transaction's primary date, or the null date if there is -- no parent transaction. postingDate2 :: Posting -> Day postingDate2 p = headDef nulldate $ catMaybes dates where dates = [pdate2 p ,maybe Nothing tdate2 $ ptransaction p ,pdate p ,maybe Nothing (Just . tdate) $ ptransaction p ] -- |Is this posting cleared? If this posting was individually marked -- as cleared, returns True. Otherwise, return the parent -- transaction's cleared status or, if there is no parent -- transaction, return False. postingCleared :: Posting -> Bool postingCleared p = if pstatus p then True else maybe False tstatus $ ptransaction p -- | Tags for this posting including any inherited from its parent transaction. postingAllTags :: Posting -> [Tag] postingAllTags p = ptags p ++ maybe [] transactionAllTags (ptransaction p) -- | Tags for this transaction including any inherited from above, when that is implemented. transactionAllTags :: Transaction -> [Tag] transactionAllTags t = ttags t -- Get the other postings from this posting's transaction. relatedPostings :: Posting -> [Posting] relatedPostings p@Posting{ptransaction=Just t} = filter (/= p) $ tpostings t relatedPostings _ = [] -- | Does this posting fall within the given date span ? isPostingInDateSpan :: DateSpan -> Posting -> Bool isPostingInDateSpan s = spanContainsDate s . postingDate isEmptyPosting :: Posting -> Bool isEmptyPosting = isZeroMixedAmount . pamount -- | Get the minimal date span which contains all the postings, or the -- null date span if there are none. postingsDateSpan :: [Posting] -> DateSpan postingsDateSpan [] = DateSpan Nothing Nothing postingsDateSpan ps = DateSpan (Just $ postingDate $ head ps') (Just $ addDays 1 $ postingDate $ last ps') where ps' = sortBy (comparing postingDate) ps -- AccountName stuff that depends on PostingType accountNamePostingType :: AccountName -> PostingType accountNamePostingType a | null a = RegularPosting | head a == '[' && last a == ']' = BalancedVirtualPosting | head a == '(' && last a == ')' = VirtualPosting | otherwise = RegularPosting accountNameWithoutPostingType :: AccountName -> AccountName accountNameWithoutPostingType a = case accountNamePostingType a of BalancedVirtualPosting -> init $ tail a VirtualPosting -> init $ tail a RegularPosting -> a accountNameWithPostingType :: PostingType -> AccountName -> AccountName accountNameWithPostingType BalancedVirtualPosting a = "["++accountNameWithoutPostingType a++"]" accountNameWithPostingType VirtualPosting a = "("++accountNameWithoutPostingType a++")" accountNameWithPostingType RegularPosting a = accountNameWithoutPostingType a -- | Prefix one account name to another, preserving posting type -- indicators like concatAccountNames. joinAccountNames :: AccountName -> AccountName -> AccountName joinAccountNames a b = concatAccountNames $ filter (not . null) [a,b] -- | Join account names into one. If any of them has () or [] posting type -- indicators, these (the first type encountered) will also be applied to -- the resulting account name. concatAccountNames :: [AccountName] -> AccountName concatAccountNames as = accountNameWithPostingType t $ intercalate ":" $ map accountNameWithoutPostingType as where t = headDef RegularPosting $ filter (/= RegularPosting) $ map accountNamePostingType as -- | Rewrite an account name using the first applicable alias from the given list, if any. accountNameApplyAliases :: [(AccountName,AccountName)] -> AccountName -> AccountName accountNameApplyAliases aliases a = withorigtype where (a',t) = (accountNameWithoutPostingType a, accountNamePostingType a) firstmatchingalias = headDef Nothing $ map Just $ filter (\(orig,_) -> orig == a' || orig `isAccountNamePrefixOf` a') aliases rewritten = maybe a' (\(orig,alias) -> alias++drop (length orig) a') firstmatchingalias withorigtype = accountNameWithPostingType t rewritten tests_Hledger_Data_Posting = TestList [ "accountNamePostingType" ~: do accountNamePostingType "a" `is` RegularPosting accountNamePostingType "(a)" `is` VirtualPosting accountNamePostingType "[a]" `is` BalancedVirtualPosting ,"accountNameWithoutPostingType" ~: do accountNameWithoutPostingType "(a)" `is` "a" ,"accountNameWithPostingType" ~: do accountNameWithPostingType VirtualPosting "[a]" `is` "(a)" ,"joinAccountNames" ~: do "a" `joinAccountNames` "b:c" `is` "a:b:c" "a" `joinAccountNames` "(b:c)" `is` "(a:b:c)" "[a]" `joinAccountNames` "(b:c)" `is` "[a:b:c]" "" `joinAccountNames` "a" `is` "a" ,"concatAccountNames" ~: do concatAccountNames [] `is` "" concatAccountNames ["a","(b)","[c:d]"] `is` "(a:b:c:d)" ] hledger-lib-0.22/Hledger/Data/Dates.hs0000644000000000000000000006731312252750510015631 0ustar0000000000000000{-# LANGUAGE NoMonoLocalBinds #-} {-| Date parsing and utilities for hledger. For date and time values, we use the standard Day and UTCTime types. A 'SmartDate' is a date which may be partially-specified or relative. Eg 2008\/12\/31, but also 2008\/12, 12\/31, tomorrow, last week, next year. We represent these as a triple of strings like (\"2008\",\"12\",\"\"), (\"\",\"\",\"tomorrow\"), (\"\",\"last\",\"week\"). A 'DateSpan' is the span of time between two specific calendar dates, or an open-ended span where one or both dates are unspecified. (A date span with both ends unspecified matches all dates.) An 'Interval' is ledger's \"reporting interval\" - weekly, monthly, quarterly, etc. -} -- XXX fromGregorian silently clips bad dates, use fromGregorianValid instead ? module Hledger.Data.Dates ( -- * Misc date handling utilities getCurrentDay, getCurrentMonth, getCurrentYear, nulldate, spanContainsDate, parsedateM, parsedate, showDate, showDateSpan, elapsedSeconds, prevday, parsePeriodExpr, nulldatespan, tests_Hledger_Data_Dates, failIfInvalidYear, datesepchar, datesepchars, spanStart, spanEnd, spansSpan, spanIntersect, spansIntersect, spanUnion, spansUnion, orDatesFrom, smartdate, splitSpan, fixSmartDate, fixSmartDateStr, fixSmartDateStrEither, fixSmartDateStrEither', daysInSpan, maybePeriod, mkdatespan, ) where import Control.Monad import Data.List import Data.Maybe import Data.Time.Format import Data.Time.Calendar import Data.Time.Calendar.OrdinalDate import Data.Time.Clock import Data.Time.LocalTime import Safe (headMay, lastMay, readMay) import System.Locale (defaultTimeLocale) import Test.HUnit import Text.ParserCombinators.Parsec import Text.Printf import Hledger.Data.Types import Hledger.Utils showDate :: Day -> String showDate = formatTime defaultTimeLocale "%C%y/%m/%d" showDateSpan (DateSpan from to) = concat [maybe "" showdate from ,"-" ,maybe "" (showdate . prevday) to ] where showdate = formatTime defaultTimeLocale "%C%y/%m/%d" -- | Get the current local date. getCurrentDay :: IO Day getCurrentDay = do t <- getZonedTime return $ localDay (zonedTimeToLocalTime t) -- | Get the current local month number. getCurrentMonth :: IO Int getCurrentMonth = do (_,m,_) <- toGregorian `fmap` getCurrentDay return m -- | Get the current local year. getCurrentYear :: IO Integer getCurrentYear = do (y,_,_) <- toGregorian `fmap` getCurrentDay return y elapsedSeconds :: Fractional a => UTCTime -> UTCTime -> a elapsedSeconds t1 = realToFrac . diffUTCTime t1 spanStart :: DateSpan -> Maybe Day spanStart (DateSpan d _) = d spanEnd :: DateSpan -> Maybe Day spanEnd (DateSpan _ d) = d -- | Get overall span enclosing multiple sequentially ordered spans. spansSpan :: [DateSpan] -> DateSpan spansSpan spans = DateSpan (maybe Nothing spanStart $ headMay spans) (maybe Nothing spanEnd $ lastMay spans) -- | Split a DateSpan into one or more consecutive spans at the specified interval. splitSpan :: Interval -> DateSpan -> [DateSpan] splitSpan _ (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing] splitSpan NoInterval s = [s] splitSpan (Days n) s = splitspan startofday (applyN n nextday) s splitSpan (Weeks n) s = splitspan startofweek (applyN n nextweek) s splitSpan (Months n) s = splitspan startofmonth (applyN n nextmonth) s splitSpan (Quarters n) s = splitspan startofquarter (applyN n nextquarter) s splitSpan (Years n) s = splitspan startofyear (applyN n nextyear) s splitSpan (DayOfMonth n) s = splitspan (nthdayofmonthcontaining n) (applyN (n-1) nextday . nextmonth) s splitSpan (DayOfWeek n) s = splitspan (nthdayofweekcontaining n) (applyN (n-1) nextday . nextweek) s -- splitSpan (WeekOfYear n) s = splitspan startofweek (applyN n nextweek) s -- splitSpan (MonthOfYear n) s = splitspan startofmonth (applyN n nextmonth) s -- splitSpan (QuarterOfYear n) s = splitspan startofquarter (applyN n nextquarter) s -- Split the given span using the provided helper functions: -- start is applied to the span's start date to get the first sub-span's start date -- next is applied to a sub-span's start date to get the next sub-span's start date splitspan :: (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan] splitspan _ _ (DateSpan Nothing Nothing) = [] splitspan start next (DateSpan Nothing (Just e)) = splitspan start next (DateSpan (Just $ start e) (Just $ next $ start e)) splitspan start next (DateSpan (Just s) Nothing) = splitspan start next (DateSpan (Just $ start s) (Just $ next $ start s)) splitspan start next span@(DateSpan (Just s) (Just e)) | s == e = [span] | otherwise = splitspan' start next span where splitspan' start next (DateSpan (Just s) (Just e)) | s >= e = [] | otherwise = DateSpan (Just subs) (Just sube) : splitspan' start next (DateSpan (Just sube) (Just e)) where subs = start s sube = next subs splitspan' _ _ _ = error' "won't happen, avoids warnings" -- | Count the days in a DateSpan, or if it is open-ended return Nothing. daysInSpan :: DateSpan -> Maybe Integer daysInSpan (DateSpan (Just d1) (Just d2)) = Just $ diffDays d2 d1 daysInSpan _ = Nothing -- | Does the span include the given date ? spanContainsDate :: DateSpan -> Day -> Bool spanContainsDate (DateSpan Nothing Nothing) _ = True spanContainsDate (DateSpan Nothing (Just e)) d = d < e spanContainsDate (DateSpan (Just b) Nothing) d = d >= b spanContainsDate (DateSpan (Just b) (Just e)) d = d >= b && d < e -- | Combine two datespans, filling any unspecified dates in the first -- with dates from the second. Not a clip operation, just uses the -- second's start/end dates as defaults when the first does not -- specify them. orDatesFrom (DateSpan a1 b1) (DateSpan a2 b2) = DateSpan a b where a = if isJust a1 then a1 else a2 b = if isJust b1 then b1 else b2 -- | Calculate the intersection of a number of datespans. spansIntersect [] = nulldatespan spansIntersect [d] = d spansIntersect (d:ds) = d `spanIntersect` (spansIntersect ds) -- | Calculate the intersection of two datespans. spanIntersect (DateSpan b1 e1) (DateSpan b2 e2) = DateSpan b e where b = latest b1 b2 e = earliest e1 e2 -- | Calculate the union of a number of datespans. spansUnion [] = nulldatespan spansUnion [d] = d spansUnion (d:ds) = d `spanUnion` (spansUnion ds) -- | Calculate the union of two datespans. spanUnion (DateSpan b1 e1) (DateSpan b2 e2) = DateSpan b e where b = earliest b1 b2 e = latest e1 e2 latest d Nothing = d latest Nothing d = d latest (Just d1) (Just d2) = Just $ max d1 d2 earliest d Nothing = d earliest Nothing d = d earliest (Just d1) (Just d2) = Just $ min d1 d2 -- | Parse a period expression to an Interval and overall DateSpan using -- the provided reference date, or return a parse error. parsePeriodExpr :: Day -> String -> Either ParseError (Interval, DateSpan) parsePeriodExpr refdate = parsewith (periodexpr refdate) maybePeriod :: Day -> String -> Maybe (Interval,DateSpan) maybePeriod refdate = either (const Nothing) Just . parsePeriodExpr refdate -- | Show a DateSpan as a human-readable pseudo-period-expression string. -- dateSpanAsText :: DateSpan -> String -- dateSpanAsText (DateSpan Nothing Nothing) = "all" -- dateSpanAsText (DateSpan Nothing (Just e)) = printf "to %s" (show e) -- dateSpanAsText (DateSpan (Just b) Nothing) = printf "from %s" (show b) -- dateSpanAsText (DateSpan (Just b) (Just e)) = printf "%s to %s" (show b) (show e) -- | Convert a single smart date string to a date span using the provided -- reference date, or raise an error. -- spanFromSmartDateString :: Day -> String -> DateSpan -- spanFromSmartDateString refdate s = spanFromSmartDate refdate sdate -- where -- sdate = fromparse $ parsewith smartdateonly s spanFromSmartDate :: Day -> SmartDate -> DateSpan spanFromSmartDate refdate sdate = DateSpan (Just b) (Just e) where (ry,rm,_) = toGregorian refdate (b,e) = span sdate span :: SmartDate -> (Day,Day) span ("","","today") = (refdate, nextday refdate) span ("","this","day") = (refdate, nextday refdate) span ("","","yesterday") = (prevday refdate, refdate) span ("","last","day") = (prevday refdate, refdate) span ("","","tomorrow") = (nextday refdate, addDays 2 refdate) span ("","next","day") = (nextday refdate, addDays 2 refdate) span ("","last","week") = (prevweek refdate, thisweek refdate) span ("","this","week") = (thisweek refdate, nextweek refdate) span ("","next","week") = (nextweek refdate, startofweek $ addDays 14 refdate) span ("","last","month") = (prevmonth refdate, thismonth refdate) span ("","this","month") = (thismonth refdate, nextmonth refdate) span ("","next","month") = (nextmonth refdate, startofmonth $ addGregorianMonthsClip 2 refdate) span ("","last","quarter") = (prevquarter refdate, thisquarter refdate) span ("","this","quarter") = (thisquarter refdate, nextquarter refdate) span ("","next","quarter") = (nextquarter refdate, startofquarter $ addGregorianMonthsClip 6 refdate) span ("","last","year") = (prevyear refdate, thisyear refdate) span ("","this","year") = (thisyear refdate, nextyear refdate) span ("","next","year") = (nextyear refdate, startofyear $ addGregorianYearsClip 2 refdate) span ("","",d) = (day, nextday day) where day = fromGregorian ry rm (read d) span ("",m,"") = (startofmonth day, nextmonth day) where day = fromGregorian ry (read m) 1 span ("",m,d) = (day, nextday day) where day = fromGregorian ry (read m) (read d) span (y,"","") = (startofyear day, nextyear day) where day = fromGregorian (read y) 1 1 span (y,m,"") = (startofmonth day, nextmonth day) where day = fromGregorian (read y) (read m) 1 span (y,m,d) = (day, nextday day) where day = fromGregorian (read y) (read m) (read d) -- showDay :: Day -> String -- showDay day = printf "%04d/%02d/%02d" y m d where (y,m,d) = toGregorian day -- | Convert a smart date string to an explicit yyyy\/mm\/dd string using -- the provided reference date, or raise an error. fixSmartDateStr :: Day -> String -> String fixSmartDateStr d s = either (\e->error' $ printf "could not parse date %s %s" (show s) (show e)) id $ fixSmartDateStrEither d s -- | A safe version of fixSmartDateStr. fixSmartDateStrEither :: Day -> String -> Either ParseError String fixSmartDateStrEither d = either Left (Right . showDate) . fixSmartDateStrEither' d fixSmartDateStrEither' :: Day -> String -> Either ParseError Day fixSmartDateStrEither' d s = case parsewith smartdateonly (lowercase s) of Right sd -> Right $ fixSmartDate d sd Left e -> Left e -- | Convert a SmartDate to an absolute date using the provided reference date. fixSmartDate :: Day -> SmartDate -> Day fixSmartDate refdate sdate = fix sdate where fix :: SmartDate -> Day fix ("","","today") = fromGregorian ry rm rd fix ("","this","day") = fromGregorian ry rm rd fix ("","","yesterday") = prevday refdate fix ("","last","day") = prevday refdate fix ("","","tomorrow") = nextday refdate fix ("","next","day") = nextday refdate fix ("","last","week") = prevweek refdate fix ("","this","week") = thisweek refdate fix ("","next","week") = nextweek refdate fix ("","last","month") = prevmonth refdate fix ("","this","month") = thismonth refdate fix ("","next","month") = nextmonth refdate fix ("","last","quarter") = prevquarter refdate fix ("","this","quarter") = thisquarter refdate fix ("","next","quarter") = nextquarter refdate fix ("","last","year") = prevyear refdate fix ("","this","year") = thisyear refdate fix ("","next","year") = nextyear refdate fix ("","",d) = fromGregorian ry rm (read d) fix ("",m,"") = fromGregorian ry (read m) 1 fix ("",m,d) = fromGregorian ry (read m) (read d) fix (y,"","") = fromGregorian (read y) 1 1 fix (y,m,"") = fromGregorian (read y) (read m) 1 fix (y,m,d) = fromGregorian (read y) (read m) (read d) (ry,rm,rd) = toGregorian refdate prevday :: Day -> Day prevday = addDays (-1) nextday = addDays 1 startofday = id thisweek = startofweek prevweek = startofweek . addDays (-7) nextweek = startofweek . addDays 7 startofweek day = fromMondayStartWeek y w 1 where (y,_,_) = toGregorian day (w,_) = mondayStartWeek day thismonth = startofmonth prevmonth = startofmonth . addGregorianMonthsClip (-1) nextmonth = startofmonth . addGregorianMonthsClip 1 startofmonth day = fromGregorian y m 1 where (y,m,_) = toGregorian day thisquarter = startofquarter prevquarter = startofquarter . addGregorianMonthsClip (-3) nextquarter = startofquarter . addGregorianMonthsClip 3 startofquarter day = fromGregorian y (firstmonthofquarter m) 1 where (y,m,_) = toGregorian day firstmonthofquarter m = ((m-1) `div` 3) * 3 + 1 thisyear = startofyear prevyear = startofyear . addGregorianYearsClip (-1) nextyear = startofyear . addGregorianYearsClip 1 startofyear day = fromGregorian y 1 1 where (y,_,_) = toGregorian day nthdayofmonthcontaining n d | d1 >= d = d1 | otherwise = d2 where d1 = addDays (fromIntegral n-1) s d2 = addDays (fromIntegral n-1) $ nextmonth s s = startofmonth d nthdayofweekcontaining n d | d1 >= d = d1 | otherwise = d2 where d1 = addDays (fromIntegral n-1) s d2 = addDays (fromIntegral n-1) $ nextweek s s = startofweek d ---------------------------------------------------------------------- -- parsing -- -- | Parse a couple of date-time string formats to a time type. -- parsedatetimeM :: String -> Maybe LocalTime -- parsedatetimeM s = firstJust [ -- parseTime defaultTimeLocale "%Y/%m/%d %H:%M:%S" s, -- parseTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" s -- ] -- | Parse a couple of date string formats to a time type. parsedateM :: String -> Maybe Day parsedateM s = firstJust [ parseTime defaultTimeLocale "%Y/%m/%d" s, parseTime defaultTimeLocale "%Y-%m-%d" s ] -- -- | Parse a date-time string to a time type, or raise an error. -- parsedatetime :: String -> LocalTime -- parsedatetime s = fromMaybe (error' $ "could not parse timestamp \"" ++ s ++ "\"") -- (parsedatetimeM s) -- | Parse a date string to a time type, or raise an error. parsedate :: String -> Day parsedate s = fromMaybe (error' $ "could not parse date \"" ++ s ++ "\"") (parsedateM s) -- | Parse a time string to a time type using the provided pattern, or -- return the default. parsetimewith :: ParseTime t => String -> String -> t -> t parsetimewith pat s def = fromMaybe def $ parseTime defaultTimeLocale pat s {-| Parse a date in any of the formats allowed in ledger's period expressions, and maybe some others: > 2004 > 2004/10 > 2004/10/1 > 10/1 > 21 > october, oct > yesterday, today, tomorrow > this/next/last week/day/month/quarter/year Returns a SmartDate, to be converted to a full date later (see fixSmartDate). Assumes any text in the parse stream has been lowercased. -} smartdate :: GenParser Char st SmartDate smartdate = do -- XXX maybe obscures date errors ? see ledgerdate (y,m,d) <- choice' [yyyymmdd, ymd, ym, md, y, d, month, mon, today, yesterday, tomorrow, lastthisnextthing] return (y,m,d) -- | Like smartdate, but there must be nothing other than whitespace after the date. smartdateonly :: GenParser Char st SmartDate smartdateonly = do d <- smartdate many spacenonewline eof return d datesepchars = "/-." datesepchar = oneOf datesepchars validYear, validMonth, validDay :: String -> Bool validYear s = length s >= 4 && isJust (readMay s :: Maybe Int) validMonth s = maybe False (\n -> n>=1 && n<=12) $ readMay s validDay s = maybe False (\n -> n>=1 && n<=31) $ readMay s failIfInvalidYear, failIfInvalidMonth, failIfInvalidDay :: (Monad m) => String -> m () failIfInvalidYear s = unless (validYear s) $ fail $ "bad year number: " ++ s failIfInvalidMonth s = unless (validMonth s) $ fail $ "bad month number: " ++ s failIfInvalidDay s = unless (validDay s) $ fail $ "bad day number: " ++ s yyyymmdd :: GenParser Char st SmartDate yyyymmdd = do y <- count 4 digit m <- count 2 digit failIfInvalidMonth m d <- count 2 digit failIfInvalidDay d return (y,m,d) ymd :: GenParser Char st SmartDate ymd = do y <- many1 digit failIfInvalidYear y datesepchar m <- many1 digit failIfInvalidMonth m datesepchar d <- many1 digit failIfInvalidDay d return $ (y,m,d) ym :: GenParser Char st SmartDate ym = do y <- many1 digit failIfInvalidYear y datesepchar m <- many1 digit failIfInvalidMonth m return (y,m,"") y :: GenParser Char st SmartDate y = do y <- many1 digit failIfInvalidYear y return (y,"","") d :: GenParser Char st SmartDate d = do d <- many1 digit failIfInvalidDay d return ("","",d) md :: GenParser Char st SmartDate md = do m <- many1 digit failIfInvalidMonth m datesepchar d <- many1 digit failIfInvalidDay d return ("",m,d) months = ["january","february","march","april","may","june", "july","august","september","october","november","december"] monthabbrevs = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","nov","dec"] -- weekdays = ["monday","tuesday","wednesday","thursday","friday","saturday","sunday"] -- weekdayabbrevs = ["mon","tue","wed","thu","fri","sat","sun"] monthIndex s = maybe 0 (+1) $ lowercase s `elemIndex` months monIndex s = maybe 0 (+1) $ lowercase s `elemIndex` monthabbrevs month :: GenParser Char st SmartDate month = do m <- choice $ map (try . string) months let i = monthIndex m return ("",show i,"") mon :: GenParser Char st SmartDate mon = do m <- choice $ map (try . string) monthabbrevs let i = monIndex m return ("",show i,"") today,yesterday,tomorrow :: GenParser Char st SmartDate today = string "today" >> return ("","","today") yesterday = string "yesterday" >> return ("","","yesterday") tomorrow = string "tomorrow" >> return ("","","tomorrow") lastthisnextthing :: GenParser Char st SmartDate lastthisnextthing = do r <- choice [ string "last" ,string "this" ,string "next" ] many spacenonewline -- make the space optional for easier scripting p <- choice [ string "day" ,string "week" ,string "month" ,string "quarter" ,string "year" ] -- XXX support these in fixSmartDate -- ++ (map string $ months ++ monthabbrevs ++ weekdays ++ weekdayabbrevs) return ("",r,p) periodexpr :: Day -> GenParser Char st (Interval, DateSpan) periodexpr rdate = choice $ map try [ intervalanddateperiodexpr rdate, intervalperiodexpr, dateperiodexpr rdate, (return (NoInterval,DateSpan Nothing Nothing)) ] intervalanddateperiodexpr :: Day -> GenParser Char st (Interval, DateSpan) intervalanddateperiodexpr rdate = do many spacenonewline i <- reportinginterval many spacenonewline s <- periodexprdatespan rdate return (i,s) intervalperiodexpr :: GenParser Char st (Interval, DateSpan) intervalperiodexpr = do many spacenonewline i <- reportinginterval return (i, DateSpan Nothing Nothing) dateperiodexpr :: Day -> GenParser Char st (Interval, DateSpan) dateperiodexpr rdate = do many spacenonewline s <- periodexprdatespan rdate return (NoInterval, s) -- Parse a reporting interval. reportinginterval :: GenParser Char st Interval reportinginterval = choice' [ tryinterval "day" "daily" Days, tryinterval "week" "weekly" Weeks, tryinterval "month" "monthly" Months, tryinterval "quarter" "quarterly" Quarters, tryinterval "year" "yearly" Years, do string "biweekly" return $ Weeks 2, do string "bimonthly" return $ Months 2, do string "every" many spacenonewline n <- fmap read $ many1 digit thsuffix many spacenonewline string "day" many spacenonewline string "of" many spacenonewline string "week" return $ DayOfWeek n, do string "every" many spacenonewline n <- fmap read $ many1 digit thsuffix many spacenonewline string "day" optional $ do many spacenonewline string "of" many spacenonewline string "month" return $ DayOfMonth n ] where thsuffix = choice' $ map string ["st","nd","rd","th"] -- Parse any of several variants of a basic interval, eg "daily", "every day", "every N days". tryinterval :: String -> String -> (Int -> Interval) -> GenParser Char st Interval tryinterval singular compact intcons = choice' [ do string compact return $ intcons 1, do string "every" many spacenonewline string singular return $ intcons 1, do string "every" many spacenonewline n <- fmap read $ many1 digit many spacenonewline string plural return $ intcons n ] where plural = singular ++ "s" periodexprdatespan :: Day -> GenParser Char st DateSpan periodexprdatespan rdate = choice $ map try [ doubledatespan rdate, fromdatespan rdate, todatespan rdate, justdatespan rdate ] doubledatespan :: Day -> GenParser Char st DateSpan doubledatespan rdate = do optional (string "from" >> many spacenonewline) b <- smartdate many spacenonewline optional (choice [string "to", string "-"] >> many spacenonewline) e <- smartdate return $ DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e) fromdatespan :: Day -> GenParser Char st DateSpan fromdatespan rdate = do b <- choice [ do string "from" >> many spacenonewline smartdate , do d <- smartdate string "-" return d ] return $ DateSpan (Just $ fixSmartDate rdate b) Nothing todatespan :: Day -> GenParser Char st DateSpan todatespan rdate = do choice [string "to", string "-"] >> many spacenonewline e <- smartdate return $ DateSpan Nothing (Just $ fixSmartDate rdate e) justdatespan :: Day -> GenParser Char st DateSpan justdatespan rdate = do optional (string "in" >> many spacenonewline) d <- smartdate return $ spanFromSmartDate rdate d -- | Make a datespan from two valid date strings parseable by parsedate -- (or raise an error). Eg: mkdatespan \"2011/1/1\" \"2011/12/31\". mkdatespan :: String -> String -> DateSpan mkdatespan b = DateSpan (Just $ parsedate b) . Just . parsedate nulldatespan :: DateSpan nulldatespan = DateSpan Nothing Nothing nulldate :: Day nulldate = parsedate "0000/00/00" tests_Hledger_Data_Dates = TestList [ "parsedate" ~: do let date1 = parsedate "2008/11/26" parsedate "2008/02/03" `is` parsetimewith "%Y/%m/%d" "2008/02/03" date1 parsedate "2008-02-03" `is` parsetimewith "%Y/%m/%d" "2008/02/03" date1 ,"period expressions" ~: do let todaysdate = parsedate "2008/11/26" let str `gives` result = show (parsewith (periodexpr todaysdate) str) `is` ("Right " ++ result) "from aug to oct" `gives` "(NoInterval,DateSpan (Just 2008-08-01) (Just 2008-10-01))" "aug to oct" `gives` "(NoInterval,DateSpan (Just 2008-08-01) (Just 2008-10-01))" "every 3 days in aug" `gives` "(Days 3,DateSpan (Just 2008-08-01) (Just 2008-09-01))" "daily from aug" `gives` "(Days 1,DateSpan (Just 2008-08-01) Nothing)" "every week to 2009" `gives` "(Weeks 1,DateSpan Nothing (Just 2009-01-01))" ,"splitSpan" ~: do let gives (interval, span) = (splitSpan interval span `is`) (NoInterval,mkdatespan "2008/01/01" "2009/01/01") `gives` [mkdatespan "2008/01/01" "2009/01/01"] (Quarters 1,mkdatespan "2008/01/01" "2009/01/01") `gives` [mkdatespan "2008/01/01" "2008/04/01" ,mkdatespan "2008/04/01" "2008/07/01" ,mkdatespan "2008/07/01" "2008/10/01" ,mkdatespan "2008/10/01" "2009/01/01" ] (Quarters 1,nulldatespan) `gives` [nulldatespan] (Days 1,mkdatespan "2008/01/01" "2008/01/01") `gives` [mkdatespan "2008/01/01" "2008/01/01"] (Quarters 1,mkdatespan "2008/01/01" "2008/01/01") `gives` [mkdatespan "2008/01/01" "2008/01/01"] (Months 1,mkdatespan "2008/01/01" "2008/04/01") `gives` [mkdatespan "2008/01/01" "2008/02/01" ,mkdatespan "2008/02/01" "2008/03/01" ,mkdatespan "2008/03/01" "2008/04/01" ] (Months 2,mkdatespan "2008/01/01" "2008/04/01") `gives` [mkdatespan "2008/01/01" "2008/03/01" ,mkdatespan "2008/03/01" "2008/05/01" ] (Weeks 1,mkdatespan "2008/01/01" "2008/01/15") `gives` [mkdatespan "2007/12/31" "2008/01/07" ,mkdatespan "2008/01/07" "2008/01/14" ,mkdatespan "2008/01/14" "2008/01/21" ] (Weeks 2,mkdatespan "2008/01/01" "2008/01/15") `gives` [mkdatespan "2007/12/31" "2008/01/14" ,mkdatespan "2008/01/14" "2008/01/28" ] (DayOfMonth 2,mkdatespan "2008/01/01" "2008/04/01") `gives` [mkdatespan "2008/01/02" "2008/02/02" ,mkdatespan "2008/02/02" "2008/03/02" ,mkdatespan "2008/03/02" "2008/04/02" ] (DayOfWeek 2,mkdatespan "2011/01/01" "2011/01/15") `gives` [mkdatespan "2011/01/04" "2011/01/11" ,mkdatespan "2011/01/11" "2011/01/18" ] ,"fixSmartDateStr" ~: do let gives = is . fixSmartDateStr (parsedate "2008/11/26") "1999-12-02" `gives` "1999/12/02" "1999.12.02" `gives` "1999/12/02" "1999/3/2" `gives` "1999/03/02" "19990302" `gives` "1999/03/02" "2008/2" `gives` "2008/02/01" "0020/2" `gives` "0020/02/01" "1000" `gives` "1000/01/01" "4/2" `gives` "2008/04/02" "2" `gives` "2008/11/02" "January" `gives` "2008/01/01" "feb" `gives` "2008/02/01" "today" `gives` "2008/11/26" "yesterday" `gives` "2008/11/25" "tomorrow" `gives` "2008/11/27" "this day" `gives` "2008/11/26" "last day" `gives` "2008/11/25" "next day" `gives` "2008/11/27" "this week" `gives` "2008/11/24" -- last monday "last week" `gives` "2008/11/17" -- previous monday "next week" `gives` "2008/12/01" -- next monday "this month" `gives` "2008/11/01" "last month" `gives` "2008/10/01" "next month" `gives` "2008/12/01" "this quarter" `gives` "2008/10/01" "last quarter" `gives` "2008/07/01" "next quarter" `gives` "2009/01/01" "this year" `gives` "2008/01/01" "last year" `gives` "2007/01/01" "next year" `gives` "2009/01/01" -- "last wed" `gives` "2008/11/19" -- "next friday" `gives` "2008/11/28" -- "next january" `gives` "2009/01/01" ] hledger-lib-0.22/tests/0000755000000000000000000000000012252750510013142 5ustar0000000000000000hledger-lib-0.22/tests/suite.hs0000644000000000000000000000031712252750510014630 0ustar0000000000000000import Hledger (tests_Hledger) import Test.Framework.Providers.HUnit (hUnitTestToTests) import Test.Framework.Runners.Console (defaultMain) main :: IO () main = defaultMain $ hUnitTestToTests tests_Hledger