hledger-lib-0.26/0000755000000000000000000000000012550610364012007 5ustar0000000000000000hledger-lib-0.26/CHANGES0000644000000000000000000000350212550610364013002 0ustar0000000000000000API-ish changes in hledger-lib. User-visible changes appear in hledger's change log. 0.26 (2015/7/12) - allow year parser to handle arbitrarily large years - Journal's Show instance reported one too many accounts - some cleanup of debug trace helpers - tighten up some date and account name parsers (don't accept leading spaces; hadddocks) - drop regexpr dependency 0.25.1 (2015/4/29) - support/require base-compat >0.8 (#245) 0.25 (2015/4/7) - GHC 7.10 compatibility (#239) 0.24.1 (2015/3/15) - fix JournalReader "ctx" compilation warning - add some type signatures in Utils to help make ghci-web 0.24 (2014/12/25) - fix combineJournalUpdates folding order - fix a regexReplaceCI bug - fix a splitAtElement bug with adjacent separators - mostly replace slow regexpr with regex-tdfa (fixes #189) - use the modern Text.Parsec API - allow transformers 0.4* - regexReplace now supports backreferences - Transactions now remember their parse location in the journal file - export Regexp types, disambiguate CsvReader's similarly-named type - export failIfInvalidMonth/Day (fixes #216) - track the commodity of zero amounts when possible (useful eg for hledger-web's multi-commodity charts) - show posting dates in debug output - more debug helpers 0.23.3 (2014/9/12) - allow transformers 0.4* 0.23.2 (2014/5/8) - postingsReport: also fix date sorting of displayed postings (#184) 0.23.1 (2014/5/7) - postingsReport: with disordered journal entries, postings before the report start date could get wrongly included. (#184) 0.23 (2014/5/1) - orDatesFrom -> spanDefaultsFrom 0.22.2 (2014/4/16) - display years before 1000 with four digits, not three - avoid pretty-show to build with GHC < 7.4 - allow text 1.1, drop data-pprint to build with GHC 7.8.x 0.22.1 (2014/1/6) and older: see http://hledger.org/release-notes or doc/CHANGES.md. hledger-lib-0.26/hledger-lib.cabal0000644000000000000000000001256612550610364015163 0ustar0000000000000000name: hledger-lib version: 0.26 stability: stable category: Finance, Console 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.8.4, GHC==7.10.1 cabal-version: >= 1.10 build-type: Simple -- data-dir: data -- data-files: -- extra-tmp-files: extra-source-files: tests/suite.hs CHANGES -- README -- sample.ledger -- sample.timelog source-repository head type: git location: https://github.com/simonmichael/hledger flag double description: Use old Double number representation (instead of Decimal), for testing/benchmarking. default: False manual: True flag old-locale description: A compatibility flag, set automatically by cabal. If false then depend on time >= 1.5, if true then depend on time < 1.5 together with old-locale. default: False library -- should set patchlevel here as in Makefile cpp-options: -DPATCHLEVEL=0 ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing -fno-warn-missing-signatures ghc-options: -fno-warn-type-defaults -fno-warn-orphans if flag(double) cpp-options: -DDOUBLE default-language: Haskell2010 exposed-modules: Hledger Hledger.Data Hledger.Data.Account Hledger.Data.AccountName Hledger.Data.Amount Hledger.Data.Commodity Hledger.Data.Dates Hledger.Data.OutputFormat Hledger.Data.Journal Hledger.Data.Ledger Hledger.Data.Posting Hledger.Data.RawOptions 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.Reports.ReportOptions Hledger.Reports.BalanceHistoryReport Hledger.Reports.BalanceReport Hledger.Reports.EntriesReport Hledger.Reports.MultiBalanceReports Hledger.Reports.PostingsReport Hledger.Reports.TransactionsReports Hledger.Utils Hledger.Utils.Debug Hledger.Utils.Regex Hledger.Utils.UTF8IOCompat build-depends: base >= 4.3 && < 5 ,base-compat >= 0.8.1 ,array ,blaze-markup >= 0.5.1 ,bytestring ,cmdargs >= 0.10 && < 0.11 ,containers ,csv -- ,data-pprint >= 0.2.3 && < 0.3 ,Decimal ,directory ,filepath ,mtl ,mtl-compat ,old-time ,parsec >= 3 ,regex-tdfa ,safe >= 0.2 ,split >= 0.1 && < 0.3 ,transformers >= 0.2 && < 0.5 ,utf8-string >= 0.3.5 && < 1.1 ,HUnit if impl(ghc >= 7.4) build-depends: pretty-show >= 1.6.4 if flag(old-locale) build-depends: time < 1.5, old-locale else build-depends: time >= 1.5 test-suite tests type: exitcode-stdio-1.0 main-is: suite.hs hs-source-dirs: tests ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing -fno-warn-missing-signatures ghc-options: -fno-warn-type-defaults -fno-warn-orphans default-language: Haskell2010 build-depends: hledger-lib , base >= 4.3 && < 5 , base-compat >= 0.8.1 , array , blaze-markup >= 0.5.1 , cmdargs , containers , csv -- , data-pprint >= 0.2.3 && < 0.3 , Decimal , directory , filepath , HUnit , mtl , mtl-compat , old-time , parsec >= 3 , regex-tdfa , safe , split , test-framework , test-framework-hunit , transformers if impl(ghc >= 7.4) build-depends: pretty-show >= 1.6.4 if flag(old-locale) build-depends: time < 1.5, old-locale else build-depends: time >= 1.5 -- 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.26/Hledger.hs0000644000000000000000000000101512550610364013712 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.26/LICENSE0000644000000000000000000010451312550610364013020 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.26/Setup.hs0000644000000000000000000000005612550610364013444 0ustar0000000000000000import Distribution.Simple main = defaultMain hledger-lib-0.26/Hledger/0000755000000000000000000000000012550610364013361 5ustar0000000000000000hledger-lib-0.26/Hledger/Data.hs0000644000000000000000000000322212550610364014565 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.RawOptions, 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.RawOptions import Hledger.Data.TimeLog import Hledger.Data.Transaction import Hledger.Data.Types tests_Hledger_Data :: Test 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.26/Hledger/Query.hs0000644000000000000000000010122312550610364015021 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, queryIsAcct, queryIsDepth, queryIsDate, queryIsDate2, queryIsDateOrDate2, queryIsStartDateOnly, queryIsSym, queryStartDate, queryEndDate, queryDateSpan, queryDateSpan', queryDepth, inAccount, inAccountQuery, -- * matching matchesTransaction, matchesPosting, matchesAccount, matchesMixedAmount, matchesAmount, words'', -- * 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) import Test.HUnit -- import Text.ParserCombinators.Parsec import Text.Parsec hiding (Empty) import Hledger.Utils import Hledger.Data.Types import Hledger.Data.AccountName import Hledger.Data.Amount (amount, nullamt, 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 Regexp -- ^ match if code matches this regexp | Desc Regexp -- ^ match if description matches this regexp | Acct Regexp -- ^ 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 ClearedStatus -- ^ match txns/postings with this cleared status (Status Uncleared matches all states except cleared) | Real Bool -- ^ match if "realness" (involves a real non-virtual account ?) has this value | Amt OrdPlus Quantity -- ^ match if the amount's numeric quantity is less than/greater than/equal to/unsignedly equal to some value | Sym Regexp -- ^ 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 Regexp (Maybe Regexp) -- ^ match if a tag's name, and optionally its value, is matched by these respective regexps -- 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, singleQuotedPattern, doubleQuotedPattern, 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 <- singleQuotedPattern <|> doubleQuotedPattern return $ prefix ++ stripquotes p singleQuotedPattern = between (char '\'') (char '\'') (many $ noneOf "'") >>= return . stripquotes doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf "\"") >>= return . stripquotes 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" ,"date2" ,"status" ,"cur" ,"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, -- or raise an error if it has invalid syntax. 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':'2':':':s) = case parsePeriodExpr d s of Left e -> error' $ "\"date2:"++s++"\" gave a "++showDateParseError e Right (_,span) -> Left $ Date2 span parseQueryTerm d ('d':'a':'t':'e':':':s) = case parsePeriodExpr d s of Left e -> error' $ "\"date:"++s++"\" gave a "++showDateParseError e Right (_,span) -> Left $ Date span parseQueryTerm _ ('s':'t':'a':'t':'u':'s':':':s) = case parseStatus s of Left e -> error' $ "\"status:"++s++"\" gave a parse error: " ++ e Right st -> Left $ Status st parseQueryTerm _ ('r':'e':'a':'l':':':s) = Left $ Real $ parseBool s || null s parseQueryTerm _ ('a':'m':'t':':':s) = Left $ Amt ord q where (ord, 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 _ ('c':'u':'r':':':s) = Left $ Sym s -- support cur: as an alias 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 Cleared) "status:*" `gives` (Left $ Status Cleared) "status:!" `gives` (Left $ Status Pending) "status:0" `gives` (Left $ Status Uncleared) "status:" `gives` (Left $ Status Uncleared) "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) ] data OrdPlus = Lt | LtEq | Gt | GtEq | Eq | AbsLt | AbsLtEq | AbsGt | AbsGtEq | AbsEq deriving (Show,Eq,Data,Typeable) -- can fail parseAmountQueryTerm :: String -> (OrdPlus, Quantity) parseAmountQueryTerm s' = case s' of -- feel free to do this a smarter way "" -> err '<':'+':s -> (Lt, readDef err s) '<':'=':'+':s -> (LtEq, readDef err s) '>':'+':s -> (Gt, readDef err s) '>':'=':'+':s -> (GtEq, readDef err s) '=':'+':s -> (Eq, readDef err s) '+':s -> (Eq, readDef err s) '<':'-':s -> (Lt, negate $ readDef err s) '<':'=':'-':s -> (LtEq, negate $ readDef err s) '>':'-':s -> (Gt, negate $ readDef err s) '>':'=':'-':s -> (GtEq, negate $ readDef err s) '=':'-':s -> (Eq, negate $ readDef err s) '-':s -> (Eq, negate $ readDef err s) '<':'=':s -> let n = readDef err s in case n of 0 -> (LtEq, 0) _ -> (AbsLtEq, n) '<':s -> let n = readDef err s in case n of 0 -> (Lt, 0) _ -> (AbsLt, n) '>':'=':s -> let n = readDef err s in case n of 0 -> (GtEq, 0) _ -> (AbsGtEq, n) '>':s -> let n = readDef err s in case n of 0 -> (Gt, 0) _ -> (AbsGt, n) '=':s -> (AbsEq, readDef err s) s -> (AbsEq, readDef err s) where err = error' $ "could not parse as '=', '<', or '>' (optional) followed by a (optionally signed) numeric quantity: " ++ s' tests_parseAmountQueryTerm = [ "parseAmountQueryTerm" ~: do let s `gives` r = parseAmountQueryTerm s `is` r "<0" `gives` (Lt,0) -- special case for convenience, since AbsLt 0 would be always false ">0" `gives` (Gt,0) -- special case for convenience and consistency with above ">10000.10" `gives` (AbsGt,10000.1) "=0.23" `gives` (AbsEq,0.23) "0.23" `gives` (AbsEq,0.23) "<=+0.23" `gives` (LtEq,0.23) "-0.23" `gives` (Eq,(-0.23)) ] parseTag :: String -> (Regexp, Maybe Regexp) parseTag s | '=' `elem` s = (n, Just $ tail v) | otherwise = (s, Nothing) where (n,v) = break (=='=') s -- | Parse the value part of a "status:" query, or return an error. parseStatus :: String -> Either String ClearedStatus parseStatus s | s `elem` ["*","1"] = Right Cleared | s `elem` ["!"] = Right Pending | s `elem` ["","0"] = Right Uncleared | otherwise = Left $ "could not parse "++show s++" as a status (should be *, ! or empty)" -- | Parse the boolean value part of a "status:" query. "1" means true, -- anything else will be parsed as false without error. parseBool :: String -> Bool parseBool s = s `elem` truestrings truestrings :: [String] truestrings = ["1"] 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 (Date2 (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 Cleared,Depth 1]], not . queryIsDepth) `gives` Status Cleared -- (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 queryIsDate2 :: Query -> Bool queryIsDate2 (Date2 _) = True queryIsDate2 _ = False queryIsDateOrDate2 :: Query -> Bool queryIsDateOrDate2 (Date _) = True queryIsDateOrDate2 (Date2 _) = True queryIsDateOrDate2 _ = False queryIsDesc :: Query -> Bool queryIsDesc (Desc _) = True queryIsDesc _ = False queryIsAcct :: Query -> Bool queryIsAcct (Acct _) = True queryIsAcct _ = False queryIsSym :: Query -> Bool queryIsSym (Sym _) = True queryIsSym _ = 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 -- | What end date (or secondary date) does this query specify, if any ? -- For OR expressions, use the latest of the dates. NOT is ignored. queryEndDate :: Bool -> Query -> Maybe Day queryEndDate secondary (Or ms) = latestMaybeDate' $ map (queryEndDate secondary) ms queryEndDate secondary (And ms) = earliestMaybeDate' $ map (queryEndDate secondary) ms queryEndDate False (Date (DateSpan _ (Just d))) = Just d queryEndDate True (Date2 (DateSpan _ (Just d))) = Just d queryEndDate _ _ = 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 date span (or secondary date span) does this query specify ? -- For OR expressions, use the widest possible span. NOT is ignored. queryDateSpan' :: Query -> DateSpan queryDateSpan' q = spansUnion $ queryDateSpans' q -- | Extract all date (or secondary date) spans specified in this query. -- NOT is ignored. queryDateSpans' :: Query -> [DateSpan] queryDateSpans' (Or qs) = concatMap queryDateSpans' qs queryDateSpans' (And qs) = concatMap queryDateSpans' qs queryDateSpans' (Date span) = [span] queryDateSpans' (Date2 span) = [span] queryDateSpans' _ = [] -- | What is the earliest of these dates, where Nothing is latest ? earliestMaybeDate :: [Maybe Day] -> Maybe Day earliestMaybeDate mds = head $ sortBy compareMaybeDates mds ++ [Nothing] -- | What is the latest of these dates, where Nothing is earliest ? latestMaybeDate :: [Maybe Day] -> Maybe Day latestMaybeDate = headDef Nothing . sortBy (flip compareMaybeDates) -- | What is the earliest of these dates, ignoring Nothings ? earliestMaybeDate' :: [Maybe Day] -> Maybe Day earliestMaybeDate' = headDef Nothing . sortBy compareMaybeDates . filter isJust -- | What is the latest of these dates, ignoring Nothings ? latestMaybeDate' :: [Maybe Day] -> Maybe Day latestMaybeDate' = headDef Nothing . sortBy (flip compareMaybeDates) . filter isJust -- | 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 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" ] matchesMixedAmount :: Query -> MixedAmount -> Bool matchesMixedAmount q (Mixed []) = q `matchesAmount` nullamt matchesMixedAmount q (Mixed as) = any (q `matchesAmount`) as -- | Does the match expression match this (simple) amount ? matchesAmount :: Query -> Amount -> Bool matchesAmount (Not q) a = not $ q `matchesAmount` a matchesAmount (Any) _ = True matchesAmount (None) _ = False matchesAmount (Or qs) a = any (`matchesAmount` a) qs matchesAmount (And qs) a = all (`matchesAmount` a) qs -- matchesAmount (Amt ord n) a = compareAmount ord n a matchesAmount (Sym r) a = regexMatchesCI ("^" ++ r ++ "$") $ acommodity a -- matchesAmount _ _ = True -- | Is this simple (single-amount) mixed amount's quantity less than, greater than, equal to, or unsignedly equal to this number ? -- For multi-amount (multiple commodities, or just unsimplified) mixed amounts this is always true. -- | Is this amount's quantity less than, greater than, equal to, or unsignedly equal to this number ? compareAmount :: OrdPlus -> Quantity -> Amount -> Bool compareAmount ord q Amount{aquantity=aq} = case ord of Lt -> aq < q LtEq -> aq <= q Gt -> aq > q GtEq -> aq >= q Eq -> aq == q AbsLt -> abs aq < abs q AbsLtEq -> abs aq <= abs q AbsGt -> abs aq > abs q AbsGtEq -> abs aq >= abs q AbsEq -> abs aq == abs q -- | 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 Uncleared) p = postingStatus p /= Cleared matchesPosting (Status s) p = postingStatus p == s matchesPosting (Real v) p = v == isReal p matchesPosting q@(Depth _) Posting{paccount=a} = q `matchesAccount` a matchesPosting q@(Amt _ _) Posting{pamount=amt} = q `matchesMixedAmount` amt -- matchesPosting q@(Amt _ _) Posting{pamount=amt} = q `matchesMixedAmount` amt -- 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 v) p = not $ null $ matchedTags n v $ postingAllTags p -- matchesPosting _ _ = False tests_matchesPosting = [ "matchesPosting" ~: do -- matching posting status.. assertBool "positive match on cleared posting status" $ (Status Cleared) `matchesPosting` nullposting{pstatus=Cleared} assertBool "negative match on cleared posting status" $ not $ (Not $ Status Cleared) `matchesPosting` nullposting{pstatus=Cleared} assertBool "positive match on unclered posting status" $ (Status Uncleared) `matchesPosting` nullposting{pstatus=Uncleared} assertBool "negative match on unclered posting status" $ not $ (Not $ Status Uncleared) `matchesPosting` nullposting{pstatus=Uncleared} assertBool "positive match on true posting status acquired from transaction" $ (Status Cleared) `matchesPosting` nullposting{pstatus=Uncleared,ptransaction=Just nulltransaction{tstatus=Cleared}} 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 Uncleared) t = tstatus t /= Cleared matchesTransaction (Status s) t = tstatus t == s 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 v) t = not $ null $ matchedTags 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 also matches posting tags assertBool "" $ (Tag "postingtag" Nothing) `matchesTransaction` nulltransaction{tpostings=[nullposting{ptags=[("postingtag","")]}]} ] -- | Filter a list of tags by matching against their names and -- optionally also their values. matchedTags :: Regexp -> Maybe Regexp -> [Tag] -> [Tag] matchedTags namepat valuepat tags = filter (match namepat valuepat) tags where match npat Nothing (n,_) = regexMatchesCI npat n match npat (Just vpat) (n,v) = regexMatchesCI npat n && regexMatchesCI vpat v -- 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.26/Hledger/Read.hs0000644000000000000000000002247012550610364014575 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, readJournalFiles, requireJournalFileExists, ensureJournalFileExists, -- * Parsers used elsewhere postingp, accountnamep, amountp, amountp', mamountp', numberp, codep, accountaliasp, -- * Tests samplejournal, tests_Hledger_Read, ) where import qualified Control.Exception as C import Control.Monad.Except 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(..), openFile, 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 (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 True >>= 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 True 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. -- Also there is a flag specifying whether to check or ignore balance assertions in the journal. readJournal :: Maybe StorageFormat -> Maybe FilePath -> Bool -> Maybe FilePath -> String -> IO (Either String Journal) readJournal format rulesfile assrt path s = 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 dbg1IO "trying reader" (rFormat r) result <- (runExceptT . (rParser r) rulesfile assrt path') s dbg1IO "reader result" $ either id show result 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 StorageFormat, Maybe FilePath, String) -> [Reader] readersFor (format,path,s) = dbg1 ("possible readers for "++show (format,path,elideRight 30 s)) $ case format of Just f -> case readerForStorageFormat f of Just r -> [r] Nothing -> [] Nothing -> case path of Nothing -> readers Just p -> case readersForPathAndData (p,s) of [] -> readers rs -> rs -- | Find the (first) reader which can handle the given format, if any. readerForStorageFormat :: StorageFormat -> Maybe Reader readerForStorageFormat 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. Also there is a flag specifying whether -- to check or ignore balance assertions in the journal. readJournalFile :: Maybe StorageFormat -> Maybe FilePath -> Bool -> FilePath -> IO (Either String Journal) readJournalFile format rulesfile assrt f = readJournalFiles format rulesfile assrt [f] readJournalFiles :: Maybe StorageFormat -> Maybe FilePath -> Bool -> [FilePath] -> IO (Either String Journal) readJournalFiles format rulesfile assrt f = do contents <- fmap concat $ mapM readFileAnyNewline f readJournal format rulesfile assrt (listToMaybe f) contents where readFileAnyNewline f = do requireJournalFileExists f h <- fileHandle f hSetNewlineMode h universalNewlineMode hGetContents h fileHandle "-" = return stdin fileHandle f = openFile f ReadMode -- | If the specified journal file does not exist, give a helpful error and quit. requireJournalFileExists :: FilePath -> IO () requireJournalFileExists "-" = return () 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" ,"" ,"comment" ,"multi line comment here" ,"for testing purposes" ,"end comment" ,"" ,"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 r <- runExceptT $ parseWithCtx nullctx JournalReader.journal "" assertBool "journal should parse an empty file" (isRight $ r) jE <- readJournal Nothing Nothing True 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.26/Hledger/Reports.hs0000644000000000000000000000233512550610364015356 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 ( module Hledger.Reports.ReportOptions, module Hledger.Reports.EntriesReport, module Hledger.Reports.PostingsReport, module Hledger.Reports.TransactionsReports, module Hledger.Reports.BalanceReport, module Hledger.Reports.MultiBalanceReports, module Hledger.Reports.BalanceHistoryReport, -- * Tests tests_Hledger_Reports ) where import Test.HUnit import Hledger.Reports.ReportOptions import Hledger.Reports.EntriesReport import Hledger.Reports.PostingsReport import Hledger.Reports.TransactionsReports import Hledger.Reports.BalanceReport import Hledger.Reports.MultiBalanceReports import Hledger.Reports.BalanceHistoryReport tests_Hledger_Reports :: Test tests_Hledger_Reports = TestList $ -- ++ tests_isInterestingIndented [ tests_Hledger_Reports_ReportOptions, tests_Hledger_Reports_EntriesReport, tests_Hledger_Reports_PostingsReport, tests_Hledger_Reports_BalanceReport ] hledger-lib-0.26/Hledger/Utils.hs0000644000000000000000000003773312550610364015032 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-| 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 Text.RegexPR, -- module Test.HUnit, -- module Text.Printf, ---- all of this one: module Hledger.Utils, module Hledger.Utils.Debug, module Hledger.Utils.Regex, -- Debug.Trace.trace, -- module Data.PPrint, -- module Hledger.Utils.UTF8IOCompat SystemString,fromSystemString,toSystemString,error',userError', -- the rest need to be done in each module I think ) where import Control.Monad (liftM) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Char 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 System.Directory (getHomeDirectory) import System.FilePath((), isRelative) import System.IO import Test.HUnit import Text.Parsec import Text.Printf -- import qualified Data.Map as Map import Hledger.Utils.Debug import Hledger.Utils.Regex -- 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, uppercase :: String -> String lowercase = map toLower uppercase = map toUpper -- | Remove leading and trailing whitespace. strip :: String -> String strip = lstrip . rstrip -- | Remove leading whitespace. lstrip :: String -> String lstrip = dropWhile (`elem` " \t") :: String -> String -- XXX isSpace ? -- | Remove trailing whitespace. rstrip :: String -> String rstrip = reverse . lstrip . reverse -- | Remove trailing newlines/carriage returns. chomp :: String -> String chomp = reverse . dropWhile (`elem` "\r\n") . reverse stripbrackets :: String -> String stripbrackets = dropWhile (`elem` "([") . reverse . dropWhile (`elem` "])") . reverse :: String -> String elideLeft :: Int -> String -> String elideLeft width s = if length s > width then ".." ++ reverse (take (width - 2) $ reverse s) else s elideRight :: Int -> String -> String 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 double 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++"'" -- | Double-quote this string if it contains whitespace, single quotes -- or double-quotes, escaping the quotes as needed. quoteIfNeeded :: String -> String quoteIfNeeded s | any (`elem` s) (quotechars++whitespacechars) = "\"" ++ escapeDoubleQuotes s ++ "\"" | otherwise = s -- | Single-quote this string if it contains whitespace or double-quotes. -- No good for strings containing single quotes. singleQuoteIfNeeded :: String -> String singleQuoteIfNeeded s | any (`elem` s) whitespacechars = "'"++s++"'" | otherwise = s quotechars, whitespacechars :: [Char] quotechars = "'\"" whitespacechars = " \t\n\r" escapeDoubleQuotes :: String -> String escapeDoubleQuotes = regexReplace "\"" "\"" 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 <- (singleQuotedPattern <|> doubleQuotedPattern <|> pattern) `sepBy` many1 spacenonewline -- eof return ss pattern = many (noneOf whitespacechars) singleQuotedPattern = between (char '\'') (char '\'') (many $ noneOf "'") doubleQuotedPattern = between (char '"') (char '"') (many $ noneOf "\"") -- | Quote-aware version of unwords - single-quote strings which contain whitespace unwords' :: [String] -> String unwords' = unwords . map quoteIfNeeded -- | 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 ' ' -- tuples first3 (x,_,_) = x second3 (_,x,_) = x third3 (_,_,x) = x first4 (x,_,_,_) = x second4 (_,x,_,_) = x third4 (_,_,x,_) = x fourth4 (_,_,_,x) = x first5 (x,_,_,_,_) = x second5 (_,x,_,_,_) = x third5 (_,_,x,_,_) = x fourth5 (_,_,_,x,_) = x fifth5 (_,_,_,_,x) = x -- math difforzero :: (Num a, Ord a) => a -> a -> a difforzero a b = maximum [(a - b), 0] -- lists splitAtElement :: Eq a => a -> [a] -> [[a]] splitAtElement x l = case l of [] -> [] e:es | e==x -> split es es -> split es where split es = let (first,rest) = break (x==) es in first : splitAtElement x rest -- 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 -- parsing -- | Backtracking choice, use this when alternatives share a prefix. -- Consumes no input if all choices fail. choice' :: Stream s m t => [ParsecT s u m a] -> ParsecT s u m a choice' = choice . map Text.Parsec.try parsewith :: Parsec [Char] () a -> String -> Either ParseError a parsewith p = runParser p () "" parseWithCtx :: Stream s m t => u -> ParsecT s u m a -> s -> m (Either ParseError a) parseWithCtx ctx p = runParserT 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 :: (Stream [Char] m Char) => ParsecT [Char] st m Char nonspace = satisfy (not . isSpace) spacenonewline :: (Stream [Char] m Char) => ParsecT [Char] st m Char spacenonewline = satisfy (`elem` " \v\f\t") restofline :: (Stream [Char] m Char) => ParsecT [Char] st m String restofline = anyChar `manyTill` newline eolof :: (Stream [Char] m Char) => ParsecT [Char] st m () 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.26/Hledger/Data/0000755000000000000000000000000012550610364014232 5ustar0000000000000000hledger-lib-0.26/Hledger/Data/Account.hs0000644000000000000000000001563612550610364016175 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 Data.Maybe 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, postings:%d, ebalance:%s, ibalance:%s)" aname (if aboring then "y" else "n" :: String) anumpostings (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 = [] , anumpostings = 0 , 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 counted = [(a, length acctamts) | acctamts@((a,_):_) <- grouped] summed = map (\as@((aname,_):_) -> (aname, sum $ map snd as)) grouped -- always non-empty nametree = treeFromPaths $ map (expandAccountName . fst) summed acctswithnames = nameTreeToAccount "root" nametree acctswithnumps = mapAccounts setnumps acctswithnames where setnumps a = a{anumpostings=fromMaybe 0 $ lookup (aname a) counted} acctswithebals = mapAccounts setebalance acctswithnumps 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 subaccounts below the specified depth, aggregating their balance at the depth limit -- (accounts at the depth limit will have any sub-balances merged into their exclusive balance). clipAccountsAndAggregate :: Int -> [Account] -> [Account] clipAccountsAndAggregate d as = combined where clipped = [a{aname=clipOrEllipsifyAccountName d $ aname a} | a <- as] combined = [a{aebalance=sum (map aebalance same)} | same@(a:_) <- groupBy (\a1 a2 -> aname a1 == aname a2) clipped] {- test cases, assuming d=1: assets:cash 1 1 assets:checking 1 1 -> as: [assets:cash 1 1, assets:checking 1 1] clipped: [assets 1 1, assets 1 1] combined: [assets 2 2] assets 0 2 assets:cash 1 1 assets:checking 1 1 -> as: [assets 0 2, assets:cash 1 1, assets:checking 1 1] clipped: [assets 0 2, assets 1 1, assets 1 1] combined: [assets 2 2] assets 0 2 assets:bank 1 2 assets:bank:checking 1 1 -> as: [assets 0 2, assets:bank 1 2, assets:bank:checking 1 1] clipped: [assets 0 2, assets 1 2, assets 1 1] combined: [assets 2 2] -} -- | 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'] where prunedsubs = concatMap prune $ asubs a a' = a{asubs=prunedsubs} -- | 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.26/Hledger/Data/AccountName.hs0000644000000000000000000001511312550610364016764 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) -- | Is the first account a parent or other ancestor of (and not the same as) the second ? 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 -- | Keep only the first n components of an account name, where n -- is a positive integer. If n is 0, returns the empty string. clipAccountName :: Int -> AccountName -> AccountName clipAccountName n = accountNameFromComponents . take n . accountNameComponents -- | Keep only the first n components of an account name, where n -- is a positive integer. If n is 0, returns "...". clipOrEllipsifyAccountName :: Int -> AccountName -> AccountName clipOrEllipsifyAccountName 0 = const "..." clipOrEllipsifyAccountName 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.26/Hledger/Data/Amount.hs0000644000000000000000000006305212550610364016037 0ustar0000000000000000{-# LANGUAGE CPP, 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, -- ** rendering amountstyle, showAmount, showAmountWithZeroCommodity, showAmountDebug, showAmountWithoutPrice, maxprecision, maxprecisionwithpoint, setAmountPrecision, withPrecision, canonicaliseAmount, -- * MixedAmount nullmixedamt, missingmixedamt, mixed, amounts, filterMixedAmount, filterMixedAmountByCommodity, normaliseMixedAmountSquashPricesForDisplay, normaliseMixedAmount, -- ** arithmetic costOfMixedAmount, divideMixedAmount, averageMixedAmounts, isNegativeMixedAmount, isZeroMixedAmount, isReallyZeroMixedAmount, isReallyZeroMixedAmountCost, -- ** rendering showMixedAmount, showMixedAmountDebug, showMixedAmountWithoutPrice, showMixedAmountOneLineWithoutPrice, showMixedAmountWithZeroCommodity, showMixedAmountWithPrecision, setMixedAmountPrecision, canonicaliseMixedAmount, -- * misc. ltraceamount, tests_Hledger_Data_Amount ) where import Data.Char (isDigit) #ifdef DOUBLE roundTo = flip const #else import Data.Decimal (roundTo) #endif import Data.Function (on) import Data.List import Data.Map (findWithDefault) import Data.Maybe 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 (Just '.') Nothing ------------------------------------------------------------------------------- -- Amount instance Show Amount where show _a@Amount{..} -- debugLevel < 2 = showAmountWithoutPrice a -- debugLevel < 3 = showAmount a | debugLevel < 6 = 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 -- | A temporary value for parsed transactions which had no amount specified. missingamt :: Amount missingamt = amount{acommodity="AUTO"} -- Handy amount constructors for tests. -- usd/eur/gbp round their argument to a whole number of pennies/cents. num n = amount{acommodity="", aquantity=n} hrs n = amount{acommodity="h", aquantity=n, astyle=amountstyle{asprecision=2, ascommodityside=R}} usd n = amount{acommodity="$", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=2}} eur n = amount{acommodity="€", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=2}} gbp n = amount{acommodity="£", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=2}} amt `at` priceamt = amt{aprice=UnitPrice priceamt} amt @@ priceamt = amt{aprice=TotalPrice priceamt} -- | Apply a binary arithmetic operator to two amounts, which should -- be in the same commodity if non-zero (warning, this is not checked). -- A zero result keeps the commodity of the second amount. -- The result's display style is that of the second amount, with -- precision set to the highest of either amount. -- Prices are ignored and discarded. -- Remember: the caller is responsible for ensuring both amounts have the same commodity. similarAmountsOp :: (Quantity -> Quantity -> Quantity) -> Amount -> Amount -> Amount similarAmountsOp op Amount{acommodity=_, aquantity=q1, astyle=AmountStyle{asprecision=p1}} Amount{acommodity=c2, aquantity=q2, astyle=s2@AmountStyle{asprecision=p2}} = -- trace ("a1:"++showAmountDebug a1) $ trace ("a2:"++showAmountDebug a2) $ traceWith (("= :"++).showAmountDebug) amount{acommodity=c2, aquantity=q1 `op` q2, astyle=s2{asprecision=max p1 p2}} -- c1==c2 || q1==0 || q2==0 = -- 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} -- | 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) XXX -- -- - 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 -> Quantity -> 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 Amount{aquantity=q} = iszero q where iszero = #ifdef DOUBLE null . filter (`elem` digits) . printf ("%."++show zeroprecision++"f") where zeroprecision = 8 #else (==0) #endif -- | 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\". The special "missing" amount is -- displayed as the empty string. showAmount :: Amount -> String showAmount = showAmountHelper False showAmountHelper :: Bool -> Amount -> String showAmountHelper _ Amount{acommodity="AUTO"} = "" showAmountHelper showzerocommodity 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 && not showzerocommodity = ("0","") | otherwise = (quantity, quoteCommoditySymbolIfNeeded c) space = if (not (null c') && ascommodityspaced) then " " else "" :: String price = showPrice p -- | Like showAmount, but show a zero amount's commodity if it has one. showAmountWithZeroCommodity :: Amount -> String showAmountWithZeroCommodity = showAmountHelper True -- | 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=mdec, asdigitgroups=mgrps}} = punctuatenumber (fromMaybe '.' mdec) mgrps $ qstr where -- isint n = fromIntegral (round n) == n qstr -- p == maxprecision && isint q = printf "%d" (round q::Integer) #ifdef DOUBLE | p == maxprecisionwithpoint = printf "%f" q | p == maxprecision = chopdotzero $ printf "%f" q | otherwise = printf ("%."++show p++"f") q #else | p == maxprecisionwithpoint = show q | p == maxprecision = chopdotzero $ show q | otherwise = show $ roundTo (fromIntegral p) q #endif -- | 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 -> Maybe DigitGroupStyle -> String -> String punctuatenumber dec mgrps s = sign ++ reverse (applyDigitGroupStyle mgrps (reverse int)) ++ frac'' where (sign,num) = break isDigit s (int,frac) = break (=='.') num frac' = dropWhile (=='.') frac frac'' | null frac' = "" | otherwise = dec:frac' applyDigitGroupStyle :: Maybe DigitGroupStyle -> String -> String applyDigitGroupStyle Nothing s = s applyDigitGroupStyle (Just (DigitGroups c gs)) s = addseps (repeatLast gs) s where addseps [] s = s addseps (g:gs) s | length s <= g = s | otherwise = let (part,rest) = splitAt g s in part ++ [c] ++ addseps gs rest repeatLast [] = [] repeatLast gs = init gs ++ repeat (last gs) 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) = normaliseMixedAmount $ Mixed $ as ++ bs (*) = error' "error, mixed amounts do not support multiplication" abs = error' "error, mixed amounts do not support abs" signum = error' "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. missingmixedamt :: MixedAmount missingmixedamt = Mixed [missingamt] -- | Convert amounts in various commodities into a normalised MixedAmount. mixed :: [Amount] -> MixedAmount mixed = normaliseMixedAmount . Mixed -- | Simplify a mixed amount's component amounts: -- -- * amounts in the same commodity are combined unless they have different prices or total prices -- -- * multiple zero amounts are replaced by just one. If they had the same commodity, it is preserved. -- -- * an empty amount list is replaced with a single commodityless zero -- -- * the special "missing" mixed amount remains unchanged -- normaliseMixedAmount :: MixedAmount -> MixedAmount normaliseMixedAmount = normaliseHelper False normaliseHelper :: Bool -> MixedAmount -> MixedAmount normaliseHelper squashprices (Mixed as) | missingamt `elem` as = missingmixedamt -- missingamt should always be alone, but detect it even if not | null nonzeros = Mixed [newzero] | otherwise = Mixed nonzeros where newzero = case filter (/= "") (map acommodity zeros) of [c] -> nullamt{acommodity=c} _ -> nullamt (zeros, nonzeros) = partition isReallyZeroAmount $ map sumSimilarAmountsUsingFirstPrice $ groupBy groupfn $ sortBy sortfn $ as sortfn | squashprices = compare `on` acommodity | otherwise = compare `on` \a -> (acommodity a, aprice a) groupfn | squashprices = (==) `on` acommodity | otherwise = \a1 a2 -> acommodity a1 == acommodity a2 && combinableprices a1 a2 combinableprices Amount{aprice=NoPrice} Amount{aprice=NoPrice} = True combinableprices Amount{aprice=UnitPrice p1} Amount{aprice=UnitPrice p2} = p1 == p2 combinableprices _ _ = False tests_normaliseMixedAmount = [ "normaliseMixedAmount" ~: do -- assertEqual "missing amount is discarded" (Mixed [nullamt]) (normaliseMixedAmount $ Mixed [usd 0, missingamt]) assertEqual "any missing amount means a missing mixed amount" missingmixedamt (normaliseMixedAmount $ Mixed [usd 0, missingamt]) assertEqual "unpriced same-commodity amounts are combined" (Mixed [usd 2]) (normaliseMixedAmount $ Mixed [usd 0, usd 2]) -- amounts with same unit price are combined normaliseMixedAmount (Mixed [usd 1 `at` eur 1, usd 1 `at` eur 1]) `is` Mixed [usd 2 `at` eur 1] -- amounts with different unit prices are not combined normaliseMixedAmount (Mixed [usd 1 `at` eur 1, usd 1 `at` eur 2]) `is` Mixed [usd 1 `at` eur 1, usd 1 `at` eur 2] -- amounts with total prices are not combined normaliseMixedAmount (Mixed [usd 1 @@ eur 1, usd 1 @@ eur 1]) `is` Mixed [usd 1 @@ eur 1, usd 1 @@ eur 1] ] -- | Like normaliseMixedAmount, but combine each commodity's amounts -- into just one by throwing away all prices except the first. This is -- only used as a rendering helper, and could show a misleading price. normaliseMixedAmountSquashPricesForDisplay :: MixedAmount -> MixedAmount normaliseMixedAmountSquashPricesForDisplay = normaliseHelper True tests_normaliseMixedAmountSquashPricesForDisplay = [ "normaliseMixedAmountSquashPricesForDisplay" ~: do normaliseMixedAmountSquashPricesForDisplay (Mixed []) `is` Mixed [nullamt] assertBool "" $ isZeroMixedAmount $ normaliseMixedAmountSquashPricesForDisplay (Mixed [usd 10 ,usd 10 @@ eur 7 ,usd (-10) ,usd (-10) @@ eur 7 ]) ] -- | Sum same-commodity amounts in a lossy way, applying the first -- price to the result and discarding any other prices. Only used as a -- rendering helper. sumSimilarAmountsUsingFirstPrice :: [Amount] -> Amount sumSimilarAmountsUsingFirstPrice [] = nullamt sumSimilarAmountsUsingFirstPrice as = (sum as){aprice=aprice $ head as} -- | Sum same-commodity amounts. If there were different prices, set -- the price to a special marker indicating "various". Only used as a -- rendering helper. -- sumSimilarAmountsNotingPriceDifference :: [Amount] -> Amount -- sumSimilarAmountsNotingPriceDifference [] = nullamt -- sumSimilarAmountsNotingPriceDifference as = undefined -- | Get a mixed amount's component amounts. amounts :: MixedAmount -> [Amount] amounts (Mixed as) = as -- | Filter a mixed amount's component amounts by a predicate. filterMixedAmount :: (Amount -> Bool) -> MixedAmount -> MixedAmount filterMixedAmount p (Mixed as) = Mixed $ filter p as -- | Return an unnormalised MixedAmount containing exactly one Amount -- with the specified commodity and the quantity of that commodity -- found in the original. NB if Amount's quantity is zero it will be -- discarded next time the MixedAmount gets normalised. filterMixedAmountByCommodity :: Commodity -> MixedAmount -> MixedAmount filterMixedAmountByCommodity c (Mixed as) = Mixed as' where as' = case filter ((==c) . acommodity) as of [] -> [nullamt{acommodity=c}] as'' -> [sum 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 -> Quantity -> MixedAmount divideMixedAmount (Mixed as) d = Mixed $ map (flip divideAmount d) as -- | Calculate the average of some mixed amounts. averageMixedAmounts :: [MixedAmount] -> MixedAmount averageMixedAmounts [] = 0 averageMixedAmounts as = sum as `divideMixedAmount` fromIntegral (length 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 $ normaliseMixedAmountSquashPricesForDisplay m -- | Does this mixed amount appear to be zero when displayed with its given precision ? isZeroMixedAmount :: MixedAmount -> Bool isZeroMixedAmount = all isZeroAmount . amounts . normaliseMixedAmountSquashPricesForDisplay -- | Is this mixed amount "really" zero ? See isReallyZeroAmount. isReallyZeroMixedAmount :: MixedAmount -> Bool isReallyZeroMixedAmount = all isReallyZeroAmount . amounts . normaliseMixedAmountSquashPricesForDisplay -- | 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' = normaliseMixedAmountSquashPricesForDisplay a -- b' = normaliseMixedAmountSquashPricesForDisplay b -- | Get the string representation of a mixed amount, after -- normalising it to one amount per commodity. Assumes amounts have -- no or similar prices, otherwise this can show misleading prices. showMixedAmount :: MixedAmount -> String showMixedAmount = showMixedAmountHelper False -- | Like showMixedAmount, but zero amounts are shown with their -- commodity if they have one. showMixedAmountWithZeroCommodity :: MixedAmount -> String showMixedAmountWithZeroCommodity = showMixedAmountHelper True showMixedAmountHelper :: Bool -> MixedAmount -> String showMixedAmountHelper showzerocommodity m = vConcatRightAligned $ map showw $ amounts $ normaliseMixedAmountSquashPricesForDisplay m where showw | showzerocommodity = showAmountWithZeroCommodity | otherwise = showAmount -- | 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 $ normaliseMixedAmountSquashPricesForDisplay 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 -- | 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) = normaliseMixedAmountSquashPricesForDisplay $ 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 -- | Get the one-line string representation of a mixed amount, but without -- any \@ prices. showMixedAmountOneLineWithoutPrice :: MixedAmount -> String showMixedAmountOneLineWithoutPrice m = concat $ intersperse ", " $ map showAmountWithoutPrice as where (Mixed as) = normaliseMixedAmountSquashPricesForDisplay $ stripPrices m stripPrices (Mixed as) = Mixed $ map stripprice as where stripprice a = a{aprice=NoPrice} -- | 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 ------------------------------------------------------------------------------- -- misc tests_Hledger_Data_Amount = TestList $ tests_normaliseMixedAmount ++ tests_normaliseMixedAmountSquashPricesForDisplay ++ [ -- 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 ,"adding mixed amounts, preserving minimum precision and a single commodity on zero" ~: do (sum $ map (Mixed . (:[])) [usd 1.25 ,usd (-1) `withPrecision` 0 ,usd (-0.25) ]) `is` Mixed [usd 0 `withPrecision` 0] ,"adding mixed amounts with total prices" ~: do (sum $ map (Mixed . (:[])) [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.26/Hledger/Data/Commodity.hs0000644000000000000000000000414412550610364016535 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 that may not be used 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.26/Hledger/Data/Dates.hs0000644000000000000000000007776012550610364015647 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE NoMonoLocalBinds #-} {-# LANGUAGE FlexibleContexts #-} {-| 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, failIfInvalidMonth, failIfInvalidDay, datesepchar, datesepchars, spanStart, spanEnd, spansSpan, spanIntersect, spansIntersect, spanDefaultsFrom, spanUnion, spansUnion, smartdate, splitSpan, fixSmartDate, fixSmartDateStr, fixSmartDateStrEither, fixSmartDateStrEither', daysInSpan, maybePeriod, mkdatespan, ) where import Prelude () import Prelude.Compat import Control.Monad import Data.List.Compat import Data.Maybe #if MIN_VERSION_time(1,5,0) import Data.Time.Format hiding (months) #else import Data.Time.Format import System.Locale (TimeLocale, defaultTimeLocale) #endif import Data.Time.Calendar import Data.Time.Calendar.OrdinalDate import Data.Time.Calendar.WeekDate import Data.Time.Clock import Data.Time.LocalTime import Safe (headMay, lastMay, readMay) import Test.HUnit import Text.Parsec import Text.Printf import Hledger.Data.Types import Hledger.Utils -- Help ppShow parse and line-wrap DateSpans better in debug output. instance Show DateSpan where show (DateSpan s1 s2) = "DateSpan \"" ++ show s1 ++ "\" \"" ++ show s2 ++ "\"" showDate :: Day -> String showDate = formatTime defaultTimeLocale "%0C%y/%m/%d" -- XXX review for more boundary crossing issues -- | Render a datespan as a display string, abbreviating into a -- compact form if possible. showDateSpan ds@(DateSpan (Just from) (Just to)) = case (toGregorian from, toGregorian to) of -- special cases we can abbreviate: -- a year, YYYY ((fy,1,1), (ty,1,1)) | fy+1==ty -> formatTime defaultTimeLocale "%0C%y" from -- a half, YYYYhN ((fy,1,1), (ty,7,1)) | fy==ty -> formatTime defaultTimeLocale "%0C%yh1" from ((fy,7,1), (ty,1,1)) | fy+1==ty -> formatTime defaultTimeLocale "%0C%yh2" from -- a quarter, YYYYqN ((fy,1,1), (ty,4,1)) | fy==ty -> formatTime defaultTimeLocale "%0C%yq1" from ((fy,4,1), (ty,7,1)) | fy==ty -> formatTime defaultTimeLocale "%0C%yq2" from ((fy,7,1), (ty,10,1)) | fy==ty -> formatTime defaultTimeLocale "%0C%yq3" from ((fy,10,1), (ty,1,1)) | fy+1==ty -> formatTime defaultTimeLocale "%0C%yq4" from -- a month, YYYY/MM ((fy,fm,1), (ty,tm,1)) | fy==ty && fm+1==tm -> formatTime defaultTimeLocale "%0C%y/%m" from ((fy,12,1), (ty,1,1)) | fy+1==ty -> formatTime defaultTimeLocale "%0C%y/%m" from -- a week (two successive mondays), -- YYYYwN ("week N of year YYYY") -- _ | let ((fy,fw,fd), (ty,tw,td)) = (toWeekDate from, toWeekDate to) in fy==ty && fw+1==tw && fd==1 && td==1 -- -> formatTime defaultTimeLocale "%0f%gw%V" from -- YYYY/MM/DDwN ("week N, starting on YYYY/MM/DD") _ | let ((fy,fw,fd), (ty,tw,td)) = (toWeekDate from, toWeekDate (addDays (-1) to)) in fy==ty && fw==tw && fd==1 && td==7 -> formatTime defaultTimeLocale "%0C%y/%m/%dw%V" from -- a day, YYYY/MM/DDd (d suffix is to distinguish from a regular date in register) ((fy,fm,fd), (ty,tm,td)) | fy==ty && fm==tm && fd+1==td -> formatTime defaultTimeLocale "%0C%y/%m/%dd" from -- crossing a year boundary ((fy,fm,fd), (ty,tm,td)) | fy+1==ty && fm==12 && tm==1 && fd==31 && td==1 -> formatTime defaultTimeLocale "%0C%y/%m/%dd" from -- crossing a month boundary XXX wrongly shows LEAPYEAR/2/28-LEAPYEAR/3/1 as LEAPYEAR/2/28 ((fy,fm,fd), (ty,tm,td)) | fy==ty && fm+1==tm && fd `elem` fromMaybe [] (lookup fm lastdayofmonth) && td==1 -> formatTime defaultTimeLocale "%0C%y/%m/%dd" from -- otherwise, YYYY/MM/DD-YYYY/MM/DD _ -> showDateSpan' ds where lastdayofmonth = [(1,[31]) ,(2,[28,29]) ,(3,[31]) ,(4,[30]) ,(5,[31]) ,(6,[30]) ,(7,[31]) ,(8,[31]) ,(9,[30]) ,(10,[31]) ,(11,[30]) ,(12,[31]) ] showDateSpan ds = showDateSpan' ds -- | Render a datespan as a display string. showDateSpan' (DateSpan from to) = concat [maybe "" showDate from ,"-" ,maybe "" (showDate . prevday) to ] -- | 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 -- might be useful later: http://en.wikipedia.org/wiki/Allen%27s_interval_algebra -- | 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 whole spans of the specified length which enclose it. -- If no interval is specified, the original span is returned. 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 -- | 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 -- | Fill any unspecified dates in the first span with the dates from -- the second one. Sort of a one-way spanIntersect. spanDefaultsFrom (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 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 <* eof) 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 -- ] parsetime :: ParseTime t => TimeLocale -> String -> String -> Maybe t parsetime = #if MIN_VERSION_time(1,5,0) parseTimeM True #else parseTime #endif -- | 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 :: Stream [Char] m Char => ParsecT [Char] st m 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 :: Stream [Char] m Char => ParsecT [Char] st m SmartDate smartdateonly = do d <- smartdate many spacenonewline eof return d datesepchars = "/-." datesepchar :: Stream [Char] m Char => ParsecT [Char] st m Char datesepchar = oneOf datesepchars validYear, validMonth, validDay :: String -> Bool validYear s = length s >= 4 && isJust (readMay s :: Maybe Year) 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 :: Stream [Char] m Char => ParsecT [Char] st m SmartDate yyyymmdd = do y <- count 4 digit m <- count 2 digit failIfInvalidMonth m d <- count 2 digit failIfInvalidDay d return (y,m,d) ymd :: Stream [Char] m Char => ParsecT [Char] st m SmartDate ymd = do y <- many1 digit failIfInvalidYear y sep <- datesepchar m <- many1 digit failIfInvalidMonth m char sep d <- many1 digit failIfInvalidDay d return $ (y,m,d) ym :: Stream [Char] m Char => ParsecT [Char] st m SmartDate ym = do y <- many1 digit failIfInvalidYear y datesepchar m <- many1 digit failIfInvalidMonth m return (y,m,"") y :: Stream [Char] m Char => ParsecT [Char] st m SmartDate y = do y <- many1 digit failIfInvalidYear y return (y,"","") d :: Stream [Char] m Char => ParsecT [Char] st m SmartDate d = do d <- many1 digit failIfInvalidDay d return ("","",d) md :: Stream [Char] m Char => ParsecT [Char] st m 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 :: Stream [Char] m Char => ParsecT [Char] st m SmartDate month = do m <- choice $ map (try . string) months let i = monthIndex m return ("",show i,"") mon :: Stream [Char] m Char => ParsecT [Char] st m SmartDate mon = do m <- choice $ map (try . string) monthabbrevs let i = monIndex m return ("",show i,"") today,yesterday,tomorrow :: Stream [Char] m Char => ParsecT [Char] st m SmartDate today = string "today" >> return ("","","today") yesterday = string "yesterday" >> return ("","","yesterday") tomorrow = string "tomorrow" >> return ("","","tomorrow") lastthisnextthing :: Stream [Char] m Char => ParsecT [Char] st m 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 :: Stream [Char] m Char => Day -> ParsecT [Char] st m (Interval, DateSpan) periodexpr rdate = choice $ map try [ intervalanddateperiodexpr rdate, intervalperiodexpr, dateperiodexpr rdate, (return (NoInterval,DateSpan Nothing Nothing)) ] intervalanddateperiodexpr :: Stream [Char] m Char => Day -> ParsecT [Char] st m (Interval, DateSpan) intervalanddateperiodexpr rdate = do many spacenonewline i <- reportinginterval many spacenonewline s <- periodexprdatespan rdate return (i,s) intervalperiodexpr :: Stream [Char] m Char => ParsecT [Char] st m (Interval, DateSpan) intervalperiodexpr = do many spacenonewline i <- reportinginterval return (i, DateSpan Nothing Nothing) dateperiodexpr :: Stream [Char] m Char => Day -> ParsecT [Char] st m (Interval, DateSpan) dateperiodexpr rdate = do many spacenonewline s <- periodexprdatespan rdate return (NoInterval, s) -- Parse a reporting interval. reportinginterval :: Stream [Char] m Char => ParsecT [Char] st m 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 :: Stream [Char] m Char => String -> String -> (Int -> Interval) -> ParsecT [Char] st m 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 :: Stream [Char] m Char => Day -> ParsecT [Char] st m DateSpan periodexprdatespan rdate = choice $ map try [ doubledatespan rdate, fromdatespan rdate, todatespan rdate, justdatespan rdate ] doubledatespan :: Stream [Char] m Char => Day -> ParsecT [Char] st m 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 :: Stream [Char] m Char => Day -> ParsecT [Char] st m 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 :: Stream [Char] m Char => Day -> ParsecT [Char] st m DateSpan todatespan rdate = do choice [string "to", string "-"] >> many spacenonewline e <- smartdate return $ DateSpan Nothing (Just $ fixSmartDate rdate e) justdatespan :: Stream [Char] m Char => Day -> ParsecT [Char] st m 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") "0000-01-01" `gives` "0000/01/01" "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.26/Hledger/Data/Journal.hs0000644000000000000000000010102612550610364016200 0ustar0000000000000000-- {-# LANGUAGE CPP #-} {-| 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 filterJournalTransactions, filterJournalPostings, filterJournalAmounts, filterTransactionAmounts, filterPostingAmount, -- * Querying journalAccountNames, journalAccountNamesUsed, -- journalAmountAndPriceCommodities, journalAmounts, -- journalCanonicalCommodities, journalDateSpan, journalDescriptions, journalFilePath, journalFilePaths, journalPostings, -- * Standard account types journalBalanceSheetAccountQuery, journalProfitAndLossAccountQuery, journalIncomeAccountQuery, journalExpenseAccountQuery, journalAssetAccountQuery, journalLiabilityAccountQuery, journalEquityAccountQuery, journalCashAccountQuery, -- * Misc canonicalStyles, 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 Safe (headMay) 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 = filter (/= "root") $ 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, ctxDefaultCommodityAndStyle = 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 j = j { jtxns = t : jtxns j } addModifierTransaction :: ModifierTransaction -> Journal -> Journal addModifierTransaction mt j = j { jmodifiertxns = mt : jmodifiertxns j } addPeriodicTransaction :: PeriodicTransaction -> Journal -> Journal addPeriodicTransaction pt j = j { jperiodictxns = pt : jperiodictxns j } addHistoricalPrice :: HistoricalPrice -> Journal -> Journal addHistoricalPrice h j = j { historical_prices = h : historical_prices j } addTimeLogEntry :: TimeLogEntry -> Journal -> Journal addTimeLogEntry tle j = j { open_timelog_entries = tle : open_timelog_entries j } -- | Unique transaction descriptions used in this journal. journalDescriptions :: Journal -> [String] journalDescriptions = nub . sort . map tdescription . jtxns -- | All postings from this journal's transactions, in order. journalPostings :: Journal -> [Posting] journalPostings = concatMap tpostings . jtxns -- | Unique account names posted to in this journal. journalAccountNamesUsed :: Journal -> [AccountName] journalAccountNamesUsed = sort . accountNamesFromPostings . journalPostings -- | Unique account names in this journal, including parent accounts containing no postings. 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 @^(debts?|liabilit(y|ies))(:|$)@. journalLiabilityAccountQuery :: Journal -> Query journalLiabilityAccountQuery _ = Acct "^(debts?|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 transactions matching the query expression. filterJournalTransactions :: Query -> Journal -> Journal filterJournalTransactions q j@Journal{jtxns=ts} = j{jtxns=filter (q `matchesTransaction`) ts} -- | 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} -- | Within each posting's amount, keep only the parts matching the query. -- This can leave unbalanced transactions. filterJournalAmounts :: Query -> Journal -> Journal filterJournalAmounts q j@Journal{jtxns=ts} = j{jtxns=map (filterTransactionAmounts q) ts} -- | Filter out all parts of this transaction's amounts which do not match the query. -- This can leave the transaction unbalanced. filterTransactionAmounts :: Query -> Transaction -> Transaction filterTransactionAmounts q t@Transaction{tpostings=ps} = t{tpostings=map (filterPostingAmount q) ps} -- | Filter out all parts of this posting's amount which do not match the query. filterPostingAmount :: Query -> Posting -> Posting filterPostingAmount q p@Posting{pamount=Mixed as} = p{pamount=Mixed $ filter (q `matchesAmount`) as} {- ------------------------------------------------------------------------------- -- 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 :: [AccountAlias] -> Journal -> Journal journalApplyAliases aliases j@Journal{jtxns=ts} = -- (if null aliases -- then id -- else (dbgtrace $ -- "applying additional command-line aliases:\n" -- ++ chomp (unlines $ map (" "++) $ lines $ ppShow aliases))) $ j{jtxns=map dotransaction ts} where dotransaction t@Transaction{tpostings=ps} = t{tpostings=map doposting ps} doposting 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, maybe check balance assertions and so on. journalFinalise :: ClockTime -> LocalTime -> FilePath -> String -> JournalContext -> Bool -> Journal -> Either String Journal journalFinalise tclock tlocal path txt ctx assrt j@Journal{files=fs} = do (journalBalanceTransactions $ journalCanonicaliseAmounts $ journalCloseTimeLogEntries tlocal $ j{ files=(path,txt):fs , filereadtime=tclock , jContext=ctx , jtxns=reverse $ jtxns j -- NOTE: see addTransaction , jmodifiertxns=reverse $ jmodifiertxns j -- NOTE: see addModifierTransaction , jperiodictxns=reverse $ jperiodictxns j -- NOTE: see addPeriodicTransaction , historical_prices=reverse $ historical_prices j -- NOTE: see addHistoricalPrice , open_timelog_entries=reverse $ open_timelog_entries j -- NOTE: see addTimeLogEntry }) >>= if assrt then journalCheckBalanceAssertions else return -- | 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,startbal) ps | null ps = (errs,startbal) | isNothing assertion = (errs,startbal) | -- bal' /= assertedbal -- MixedAmount's Eq instance currently gets confused by different precisions not $ isReallyZeroMixedAmount (bal - assertedbal) = (errs++[err], fullbal) | otherwise = (errs,fullbal) where p = last ps assertion = pbalanceassertion p Just assertedbal = dbg2 "assertedbal" assertion assertedcomm = dbg2 "assertedcomm" $ maybe "" acommodity $ headMay $ amounts assertedbal fullbal = dbg2 "fullbal" $ sum $ [dbg2 "startbal" startbal] ++ map pamount ps singlebal = dbg2 "singlebal" $ filterMixedAmount (\a -> acommodity a == assertedcomm) fullbal bal = singlebal -- check single-commodity balance like Ledger; maybe add == FULLBAL later err = printf "Balance assertion failed for account %s on %s\n%sAfter posting:\n %s\nexpected balance in commodity \"%s\" is %s, calculated balance was %s." (paccount p) (show $ postingDate p) (maybe "" (("In transaction:\n"++).show) $ ptransaction p) (show p) assertedcomm (showMixedAmount assertedbal) (showMixedAmount singlebal) -- 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 $ dbg8 "journalAmounts" $ 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} -- | 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, canonicalStyleFrom $ map astyle as) | (c,as) <- commamts] -- Given an ordered list of amount styles for a commodity, build a canonical style. canonicalStyleFrom :: [AmountStyle] -> AmountStyle canonicalStyleFrom [] = amountstyle canonicalStyleFrom ss@(first:_) = first{asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps} where -- precision is the maximum of all precisions seen prec = maximum $ map asprecision ss -- find the first decimal point and the first digit group style seen, -- or use defaults. mdec = Just $ headDef '.' $ catMaybes $ map asdecimalpoint ss mgrps = maybe Nothing Just $ headMay $ catMaybes $ map asdigitgroups ss -- | 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 enclosing the dates (primary or secondary) -- of all this journal's transactions and postings, or DateSpan Nothing Nothing -- if there are none. journalDateSpan :: Bool -> Journal -> DateSpan journalDateSpan secondary j | null ts = DateSpan Nothing Nothing | otherwise = DateSpan (Just earliest) (Just $ addDays 1 latest) where earliest = minimum dates latest = maximum dates dates = pdates ++ tdates tdates = map (if secondary then transactionDate2 else tdate) ts pdates = concatMap (catMaybes . map (if secondary then (Just . postingDate2) else pdate) . tpostings) ts ts = jtxns j -- #ifdef TESTS test_journalDateSpan = do "journalDateSpan" ~: do assertEqual "" (DateSpan (Just $ fromGregorian 2014 1 10) (Just $ fromGregorian 2014 10 11)) (journalDateSpan True j) where j = nulljournal{jtxns = [nulltransaction{tdate = parsedate "2014/02/01" ,tpostings = [posting{pdate=Just (parsedate "2014/01/10")}] } ,nulltransaction{tdate = parsedate "2014/09/01" ,tpostings = [posting{pdate2=Just (parsedate "2014/10/10")}] } ]} -- #endif -- 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 { tsourcepos=nullsourcepos, tdate=parsedate "2008/01/01", tdate2=Nothing, tstatus=Uncleared, tcode="", tdescription="income", tcomment="", ttags=[], tpostings= ["assets:bank:checking" `post` usd 1 ,"income:salary" `post` missingamt ], tpreceding_comment_lines="" } , txnTieKnot $ Transaction { tsourcepos=nullsourcepos, tdate=parsedate "2008/06/01", tdate2=Nothing, tstatus=Uncleared, tcode="", tdescription="gift", tcomment="", ttags=[], tpostings= ["assets:bank:checking" `post` usd 1 ,"income:gifts" `post` missingamt ], tpreceding_comment_lines="" } , txnTieKnot $ Transaction { tsourcepos=nullsourcepos, tdate=parsedate "2008/06/02", tdate2=Nothing, tstatus=Uncleared, tcode="", tdescription="save", tcomment="", ttags=[], tpostings= ["assets:bank:saving" `post` usd 1 ,"assets:bank:checking" `post` usd (-1) ], tpreceding_comment_lines="" } , txnTieKnot $ Transaction { tsourcepos=nullsourcepos, tdate=parsedate "2008/06/03", tdate2=Nothing, tstatus=Cleared, 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 { tsourcepos=nullsourcepos, tdate=parsedate "2008/12/31", tdate2=Nothing, tstatus=Uncleared, 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 $ [ test_journalDateSpan -- "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.26/Hledger/Data/Ledger.hs0000644000000000000000000000712112550610364015771 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 this ledger's -- journal but not the ledger's 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' = filterJournalAmounts (filterQuery queryIsSym q) $ -- remove amount parts which the query's sym: terms would exclude 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.26/Hledger/Data/OutputFormat.hs0000644000000000000000000001212712550610364017242 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} module Hledger.Data.OutputFormat ( parseStringFormat , formatsp , formatValue , OutputFormat(..) , HledgerFormatField(..) , tests ) where import Prelude () import Prelude.Compat import Numeric import Data.Char (isPrint) import Data.Maybe import Test.HUnit import Text.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" parseStringFormat :: String -> Either String [OutputFormat] parseStringFormat input = case (runParser (formatsp <* eof) () "(unknown)") input of Left y -> Left $ show y Right x -> Right x {- Parsers -} field :: Stream [Char] m Char => ParsecT [Char] st m 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 :: Stream [Char] m Char => ParsecT [Char] st m OutputFormat 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 :: Stream [Char] m Char => ParsecT [Char] st m OutputFormat formatLiteral = do s <- many1 c return $ FormatLiteral s where isPrintableButNotPercentage x = isPrint x && (not $ x == '%') c = (satisfy isPrintableButNotPercentage "printable character") <|> try (string "%%" >> return '%') formatp :: Stream [Char] m Char => ParsecT [Char] st m OutputFormat formatp = formatField <|> formatLiteral formatsp :: Stream [Char] m Char => ParsecT [Char] st m [OutputFormat] formatsp = many formatp testFormat :: OutputFormat -> 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 -> [OutputFormat] -> Assertion testParser s expected = case (parseStringFormat 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.26/Hledger/Data/Posting.hs0000644000000000000000000002311212550610364016210 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 postingStatus, isReal, isVirtual, isBalancedVirtual, isEmptyPosting, hasAmount, postingAllTags, transactionAllTags, relatedPostings, -- * date operations postingDate, postingDate2, isPostingInDateSpan, isPostingInDateSpan', postingsDateSpan, 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=Uncleared ,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]} -- XXX once rendered user output, but just for debugging now; clean up showPosting :: Posting -> String showPosting p@Posting{paccount=a,pamount=amt,ptype=t} = unlines $ [concatTopPadded [show (postingDate p) ++ " ", 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 ] -- | Get a posting's cleared status: cleared or pending if those are -- explicitly set, otherwise the cleared status of its parent -- transaction, or uncleared if there is no parent transaction. (Note -- Uncleared's ambiguity, it can mean "uncleared" or "don't know". postingStatus :: Posting -> ClearedStatus postingStatus Posting{pstatus=s, ptransaction=mt} | s == Uncleared = case mt of Just t -> tstatus t Nothing -> Uncleared | otherwise = s -- | Tags for this posting including any inherited from its parent transaction. postingAllTags :: Posting -> [Tag] postingAllTags p = ptags p ++ maybe [] ttags (ptransaction p) -- | Tags for this transaction including any from its postings. transactionAllTags :: Transaction -> [Tag] transactionAllTags t = ttags t ++ concatMap ptags (tpostings 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 -- --date2-sensitive version, separate for now to avoid disturbing multiBalanceReport. isPostingInDateSpan' :: WhichDate -> DateSpan -> Posting -> Bool isPostingInDateSpan' PrimaryDate s = spanContainsDate s . postingDate isPostingInDateSpan' SecondaryDate s = spanContainsDate s . postingDate2 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 -- --date2-sensitive version, as above. postingsDateSpan' :: WhichDate -> [Posting] -> DateSpan postingsDateSpan' _ [] = DateSpan Nothing Nothing postingsDateSpan' wd ps = DateSpan (Just $ postingdate $ head ps') (Just $ addDays 1 $ postingdate $ last ps') where ps' = sortBy (comparing postingdate) ps postingdate = if wd == PrimaryDate then postingDate else postingDate2 -- 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 all matching aliases from the given list, in sequence. -- Each alias sees the result of applying the previous aliases. accountNameApplyAliases :: [AccountAlias] -> AccountName -> AccountName accountNameApplyAliases aliases a = accountNameWithPostingType atype aname' where (aname,atype) = (accountNameWithoutPostingType a, accountNamePostingType a) aname' = foldl (\acct alias -> dbg6 "result" $ aliasReplace (dbg6 "alias" alias) (dbg6 "account" acct)) aname aliases -- aliasMatches :: AccountAlias -> AccountName -> Bool -- aliasMatches (BasicAlias old _) a = old `isAccountNamePrefixOf` a -- aliasMatches (RegexAlias re _) a = regexMatchesCI re a aliasReplace :: AccountAlias -> AccountName -> AccountName aliasReplace (BasicAlias old new) a | old `isAccountNamePrefixOf` a || old == a = new ++ drop (length old) a | otherwise = a aliasReplace (RegexAlias re repl) a = regexReplaceCI re repl a 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.26/Hledger/Data/RawOptions.hs0000644000000000000000000000343412550610364016677 0ustar0000000000000000{-| hledger's cmdargs modes parse command-line arguments to an intermediate format, RawOpts (an association list), rather than a fixed ADT like CliOpts. This allows the modes and flags to be reused more easily by hledger commands/scripts in this and other packages. -} module Hledger.Data.RawOptions ( RawOpts, setopt, setboolopt, inRawOpts, boolopt, stringopt, maybestringopt, listofstringopt, intopt, maybeintopt, optserror ) where import Data.Maybe import Safe import Hledger.Utils -- | The result of running cmdargs: an association list of option names to string values. type RawOpts = [(String,String)] setopt :: String -> String -> RawOpts -> RawOpts setopt name val = (++ [(name, quoteIfNeeded val)]) setboolopt :: String -> RawOpts -> RawOpts setboolopt name = (++ [(name,"")]) -- | Is the named option present ? inRawOpts :: String -> RawOpts -> Bool inRawOpts name = isJust . lookup name boolopt :: String -> RawOpts -> Bool boolopt = inRawOpts maybestringopt :: String -> RawOpts -> Maybe String maybestringopt name = maybe Nothing (Just . stripquotes) . lookup name . reverse stringopt :: String -> RawOpts -> String stringopt name = fromMaybe "" . maybestringopt name listofstringopt :: String -> RawOpts -> [String] listofstringopt name rawopts = [v | (k,v) <- rawopts, k==name] maybeintopt :: String -> RawOpts -> Maybe Int maybeintopt name rawopts = let ms = maybestringopt name rawopts in case ms of Nothing -> Nothing Just s -> Just $ readDef (optserror $ "could not parse "++name++" number: "++s) s intopt :: String -> RawOpts -> Int intopt name = fromMaybe 0 . maybeintopt name -- | Raise an error, showing the specified message plus a hint about --help. optserror :: String -> a optserror = error' . (++ " (run with --help for usage)") hledger-lib-0.26/Hledger/Data/TimeLog.hs0000644000000000000000000001320312550610364016125 0ustar0000000000000000{-# LANGUAGE CPP #-} {-| 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 #if !(MIN_VERSION_time(1,5,0)) import System.Locale (defaultTimeLocale) #endif 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 %s" (show $ tlcode t) (show $ tldatetime t) (tlaccount t) (tldescription 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 (tlsourcepos i) 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 { tsourcepos = tlsourcepos i, tdate = idate, tdate2 = Nothing, tstatus = Cleared, tcode = "", tdescription = desc, tcomment = "", ttags = [], tpostings = ps, tpreceding_comment_lines="" } itime = tldatetime i otime = tldatetime o itod = localTimeOfDay itime otod = localTimeOfDay otime idate = localDay itime desc | null (tldescription i) = showtime itod ++ "-" ++ showtime otod | otherwise = tldescription i showtime = take 5 . show hours = elapsedSeconds (toutc otime) (toutc itime) / 3600 where toutc = localTimeToUTC utc acctname = tlaccount i 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 nullsourcepos In mktime d = LocalTime d . fromMaybe midnight . #if MIN_VERSION_time(1,5,0) parseTimeM True defaultTimeLocale "%H:%M:%S" #else parseTime defaultTimeLocale "%H:%M:%S" #endif 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.26/Hledger/Data/Transaction.hs0000644000000000000000000006301012550610364017053 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 nullsourcepos, 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 Text.Parsec.Pos 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)) nullsourcepos :: SourcePos nullsourcepos = initialPos "" nulltransaction :: Transaction nulltransaction = Transaction { tsourcepos=nullsourcepos, tdate=nulldate, tdate2=Nothing, tstatus=Uncleared, 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=Uncleared, tcode="code", tdescription="desc", tcomment="tcomment1\ntcomment2\n", ttags=[("ttag1","val1")], tpostings=[ nullposting{ pstatus=Cleared, 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.00h", " ; pcomment2", "" ] ] -- cf 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 | tstatus t == Cleared = " *" | tstatus t == Pending = " !" | otherwise = "" 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 == Cleared 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=Cleared, 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.00h ; 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(s), or return an error message. -- Balancing is affected by commodity display precisions, so those can -- (optionally) be provided. balanceTransaction :: Maybe (Map.Map Commodity AmountStyle) -> Transaction -> Either String Transaction balanceTransaction styles t = case inferBalancingAmount t of Left err -> Left err Right t' -> let t'' = inferBalancingPrices t' in if isTransactionBalanced styles t'' then Right $ txnTieKnot t'' else Left $ printerr $ nonzerobalanceerror t'' where 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 -- | Infer up to one missing amount for this transactions's real postings, and -- likewise for its balanced virtual postings, if needed; or return an error -- message if we can't. -- -- We can infer a missing amount when there are multiple postings and exactly -- one of them is amountless. If the amounts had price(s) the inferred amount -- have the same price(s), and will be converted to the price commodity. -- inferBalancingAmount :: Transaction -> Either String Transaction inferBalancingAmount t@Transaction{tpostings=ps} | length amountlessrealps > 1 = Left $ printerr "could not balance this transaction - can't have more than one real posting with no amount (remember to put 2 or more spaces before amounts)" | length amountlessbvps > 1 = Left $ printerr "could not balance this transaction - can't have more than one balanced virtual posting with no amount (remember to put 2 or more spaces before amounts)" | otherwise = Right t{tpostings=map inferamount ps} where printerr s = intercalate "\n" [s, showTransactionUnelided t] ((amountfulrealps, amountlessrealps), realsum) = (partition hasAmount (realPostings t), sum $ map pamount amountfulrealps) ((amountfulbvps, amountlessbvps), bvsum) = (partition hasAmount (balancedVirtualPostings t), sum $ map pamount amountfulbvps) inferamount p@Posting{ptype=RegularPosting} | not (hasAmount p) = p{pamount=costOfMixedAmount (-realsum)} inferamount p@Posting{ptype=BalancedVirtualPosting} | not (hasAmount p) = p{pamount=costOfMixedAmount (-bvsum)} inferamount p = p -- | Infer prices for this transaction's posting amounts, if needed to make -- the postings balance, and if possible. This is done once for the real -- postings and again (separately) for the balanced virtual postings. When -- it's not possible, the transaction is left unchanged. -- -- The simplest example is a transaction with two postings, each in a -- different commodity, with no prices specified. In this case we'll add a -- price to the first posting such that it can be converted to the commodity -- of the second posting (with -B), and such that the postings balance. -- -- In general, we can infer a conversion price when the sum of posting amounts -- contains exactly two different commodities and no explicit prices. Also -- all postings are expected to contain an explicit amount (no missing -- amounts) in a single commodity. Otherwise no price inferring is attempted. -- -- The transaction itself could contain more than two commodities, and/or -- prices, if they cancel out; what matters is that the sum of posting amounts -- contains exactly two commodities and zero prices. -- -- There can also be more than two postings in either of the commodities. -- -- We want to avoid excessive display of digits when the calculated price is -- an irrational number, while hopefully also ensuring the displayed numbers -- make sense if the user does a manual calculation. This is (mostly) achieved -- in two ways: -- -- - when there is only one posting in the "from" commodity, a total price -- (@@) is used, and all available decimal digits are shown -- -- - otherwise, a suitable averaged unit price (@) is applied to the relevant -- postings, with display precision equal to the summed display precisions -- of the two commodities being converted between, or 2, whichever is larger. -- -- (We don't always calculate a good-looking display precision for unit prices -- when the commodity display precisions are low, eg when a journal doesn't -- use any decimal places. The minimum of 2 helps make the prices shown by the -- print command a bit less surprising in this case. Could do better.) -- inferBalancingPrices :: Transaction -> Transaction inferBalancingPrices t@Transaction{tpostings=ps} = t{tpostings=ps'} where ps' = map (priceInferrerFor t BalancedVirtualPosting) $ map (priceInferrerFor t RegularPosting) $ ps -- | Generate a posting update function which assigns a suitable balancing -- price to the posting, if and as appropriate for the given transaction and -- posting type (real or balanced virtual). priceInferrerFor :: Transaction -> PostingType -> (Posting -> Posting) priceInferrerFor t pt = inferprice where postings = filter ((==pt).ptype) $ tpostings t pmixedamounts = map pamount postings pamounts = concatMap amounts pmixedamounts pcommodities = map acommodity pamounts sumamounts = amounts $ sum pmixedamounts -- sum normalises to one amount per commodity & price sumcommodities = map acommodity sumamounts sumprices = filter (/=NoPrice) $ map aprice sumamounts caninferprices = length sumcommodities == 2 && null sumprices inferprice p@Posting{pamount=Mixed [a]} | caninferprices && ptype p == pt && acommodity a == fromcommodity = p{pamount=Mixed [a{aprice=conversionprice}]} where fromcommodity = head $ filter (`elem` sumcommodities) pcommodities -- these heads are ugly but should be safe conversionprice | fromcount==1 = TotalPrice $ abs toamount `withPrecision` maxprecision | otherwise = UnitPrice $ abs unitprice `withPrecision` unitprecision where fromcount = length $ filter ((==fromcommodity).acommodity) pamounts fromamount = head $ filter ((==fromcommodity).acommodity) sumamounts tocommodity = head $ filter (/=fromcommodity) sumcommodities toamount = head $ filter ((==tocommodity).acommodity) sumamounts unitprice = toamount `divideAmount` (aquantity fromamount) unitprecision = max 2 ((asprecision $ astyle $ toamount) + (asprecision $ astyle $ fromamount)) inferprice p = p -- 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, so that eg -- relatedPostings works right. 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 nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "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 nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "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 nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "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 nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "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 nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "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 nullsourcepos (parsedate "2010/01/01") Nothing Uncleared "" "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 nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "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 nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "test" "" [] [posting{paccount="a", pamount=missingmixedamt} ,posting{paccount="b", pamount=missingmixedamt} ] "")) let e = balanceTransaction Nothing (Transaction nullsourcepos (parsedate "2007/01/28") Nothing Uncleared "" "" "" [] [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 nullsourcepos (parsedate "2011/01/01") Nothing Uncleared "" "" "" [] [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 nullsourcepos (parsedate "2011/01/01") Nothing Uncleared "" "" "" [] [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 nullsourcepos (parsedate "2011/01/01") Nothing Uncleared "" "" "" [] [posting{paccount="a", pamount=Mixed [usd 1 @@ eur 1]} ,posting{paccount="a", pamount=Mixed [usd (-2) @@ eur 1]} ] "")) ,"isTransactionBalanced" ~: do let t = Transaction nullsourcepos (parsedate "2009/01/01") Nothing Uncleared "" "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 nullsourcepos (parsedate "2009/01/01") Nothing Uncleared "" "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 nullsourcepos (parsedate "2009/01/01") Nothing Uncleared "" "a" "" [] [posting{paccount="b", pamount=Mixed [usd 1.00], ptransaction=Just t} ] "" assertBool "detect unbalanced, one posting" (not $ isTransactionBalanced Nothing t) let t = Transaction nullsourcepos (parsedate "2009/01/01") Nothing Uncleared "" "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 nullsourcepos (parsedate "2009/01/01") Nothing Uncleared "" "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 nullsourcepos (parsedate "2009/01/01") Nothing Uncleared "" "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 nullsourcepos (parsedate "2009/01/01") Nothing Uncleared "" "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.26/Hledger/Data/Types.hs0000644000000000000000000002702012550610364015673 0ustar0000000000000000{-# LANGUAGE CPP, DeriveDataTypeable, StandaloneDeriving, TypeSynonymInstances, FlexibleInstances #-} {-| 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, cleared 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.Except (ExceptT) import Data.Data #ifndef DOUBLE import Data.Decimal import Text.Blaze (ToMarkup(..)) #endif import qualified Data.Map as M import Data.Time.Calendar import Data.Time.LocalTime import System.Time (ClockTime(..)) import Text.Parsec.Pos import Hledger.Utils.Regex type SmartDate = (String,String,String) data WhichDate = PrimaryDate | SecondaryDate deriving (Eq,Show) data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,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 AccountAlias = BasicAlias AccountName AccountName | RegexAlias Regexp Replacement deriving ( Eq ,Read ,Show ,Ord ,Data ,Typeable ) data Side = L | R deriving (Eq,Show,Read,Ord,Typeable,Data) type Commodity = String -- | The basic numeric type used in amounts. Different implementations -- can be selected via cabal flag for testing and benchmarking purposes. numberRepresentation :: String #ifdef DOUBLE type Quantity = Double numberRepresentation = "Double" #else type Quantity = Decimal deriving instance Data (Quantity) -- The following is for hledger-web, and requires blaze-markup. -- Doing it here avoids needing a matching flag on the hledger-web package. instance ToMarkup (Quantity) where toMarkup = toMarkup . show numberRepresentation = "Decimal" #endif -- | 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 :: Maybe Char, -- ^ character used as decimal point: period or comma. Nothing means "unspecified, use default" asdigitgroups :: Maybe DigitGroupStyle -- ^ style for displaying digit groups, if any } deriving (Eq,Ord,Read,Show,Typeable,Data) -- | A style for displaying digit groups in the integer part of a -- floating point number. It consists of the character used to -- separate groups (comma or period, whichever is not used as decimal -- point), and the size of each group, starting with the one nearest -- the decimal point. The last group size is assumed to repeat. Eg, -- comma between thousands is DigitGroups ',' [3]. data DigitGroupStyle = DigitGroups Char [Int] 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 ClearedStatus = Uncleared | Pending | Cleared deriving (Eq,Ord,Typeable,Data) instance Show ClearedStatus where -- custom show show Uncleared = "" -- a bad idea show Pending = "!" -- don't do it show Cleared = "*" 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 :: ClearedStatus, 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 { tsourcepos :: SourcePos, tdate :: Day, tdate2 :: Maybe Day, tstatus :: ClearedStatus, 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 { tlsourcepos :: SourcePos, tlcode :: TimeLogCode, tldatetime :: LocalTime, tlaccount :: String, tldescription :: 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 , ctxDefaultCommodityAndStyle :: !(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 :: ![AccountAlias] -- ^ 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. 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 = ExceptT String IO (Journal -> Journal) -- | The id of a data format understood by hledger, eg @journal@ or @csv@. type StorageFormat = 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 :: StorageFormat -- 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 -> Bool -> FilePath -> String -> ExceptT String IO Journal } instance Show Reader where show r = rFormat r ++ " reader" -- format strings data HledgerFormatField = AccountField | DefaultDateField | DescriptionField | TotalField | DepthSpacerField | FieldNo Int deriving (Show, Eq) data OutputFormat = 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.26/Hledger/Read/0000755000000000000000000000000012550610364014234 5ustar0000000000000000hledger-lib-0.26/Hledger/Read/CsvReader.hs0000644000000000000000000007514012550610364016455 0ustar0000000000000000{-# LANGUAGE CPP #-} {-| A reader for CSV data, using an extra rules file to help interpret the data. -} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} module Hledger.Read.CsvReader ( -- * Reader reader, -- * Misc. CsvRecord, -- rules, rulesFileFor, parseRulesFile, transactionFromCsvRecord, -- * Tests tests_Hledger_Read_CsvReader ) where import Prelude () import Prelude.Compat hiding (getContents) import Control.Exception hiding (try) import Control.Monad import Control.Monad.Except -- import Test.HUnit import Data.Char (toLower, isDigit, isSpace) import Data.List.Compat import Data.Maybe import Data.Ord import Data.Time.Calendar (Day) #if MIN_VERSION_time(1,5,0) import Data.Time.Format (parseTimeM, defaultTimeLocale) #else import Data.Time.Format (parseTime) import System.Locale (defaultTimeLocale) #endif import Safe import System.Directory (doesFileExist) import System.FilePath import System.IO (stderr) import Test.HUnit import Text.CSV (parseCSV, CSV) import Text.Parsec hiding (parse) import Text.Parsec.Pos import Text.Parsec.Error import Text.Printf (hPrintf,printf) import Hledger.Data import Hledger.Utils.UTF8IOCompat (getContents) import Hledger.Utils import Hledger.Read.JournalReader (amountp, statusp) reader :: Reader reader = Reader format detect parse format :: String format = "csv" -- | Does the given file path and data look like it might be CSV ? detect :: FilePath -> String -> Bool detect f s | f /= "-" = takeExtension f == '.':format -- from a file: yes if the extension is .csv | otherwise = length (filter (==',') s) >= 2 -- from stdin: yes if there are two or more commas -- | 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 -> Bool -> FilePath -> String -> ExceptT String IO Journal parse rulesfile _ f s = 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 reading CSV from stdin" readJournalFromCsv mrulesfile csvfile csvdata = handle (\e -> return $ Left $ show (e :: IOException)) $ do let throwerr = throw.userError -- parse rules let rulesfile = fromMaybe (rulesFileFor csvfile) mrulesfile created <- 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_ <- liftIO $ runExceptT $ parseRulesFile rulesfile let rules = case rules_ of Right (t::CsvRules) -> t Left err -> throwerr $ show err dbg2IO "rules" rules -- apply skip directive let skip = maybe 0 oneorerror $ getDirective "skip" rules where oneorerror "" = 1 oneorerror s = readDef (throwerr $ "could not parse skip value: " ++ show s) s -- parse csv -- parsec seems to fail if you pass it "-" here let parsecfilename = if csvfile == "-" then "(stdin)" else csvfile records <- (either throwerr id . dbg2 "validateCsv" . validateCsv skip . dbg2 "parseCsv") `fmap` parseCsv parsecfilename csvdata dbg1IO "first 3 csv records" $ take 3 records -- identify header lines -- let (headerlines, datalines) = identifyHeaderLines records -- mfieldnames = lastMay headerlines -- convert to transactions and return as a journal let txns = snd $ mapAccumL (\pos r -> (pos, transactionFromCsvRecord (incSourceLine pos 1) rules r)) (initialPos parsecfilename) records -- heuristic: if the records appear to have been in reverse date order, -- reverse them all as well as doing a txn date sort, -- so that same-day txns' original order is preserved txns' | length txns > 1 && tdate (head txns) > tdate (last txns) = reverse txns | otherwise = txns 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 :: Int -> Either ParseError CSV -> Either String [CsvRecord] validateCsv _ (Left e) = Left $ show e validateCsv numhdrlines (Right rs) = validate $ drop numhdrlines $ 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#csv-files" ,"" ,"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 = [RegexpPattern] -- match if any regexps match any of the csv fields -- type FieldMatcher = (CsvFieldName, [RegexpPattern]) -- match if any regexps match this csv field type DateFormat = String type RegexpPattern = 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 -> ExceptT String IO CsvRules parseRulesFile f = do s <- liftIO $ (readFile' f >>= expandIncludes (takeDirectory f)) let rules = parseCsvRules f s case rules of Left e -> ExceptT $ return $ Left $ show e Right r -> do r_ <- liftIO $ runExceptT $ validateRules r ExceptT $ case r_ of Left e -> return $ Left $ show $ toParseError e Right r -> return $ 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 :: FilePath -> String -> IO String expandIncludes basedir content = do let (ls,rest) = break (isPrefixOf "include") $ lines content case rest of [] -> return $ unlines ls (('i':'n':'c':'l':'u':'d':'e':f):ls') -> do let f' = basedir dropWhile isSpace f basedir' = takeDirectory f' included <- readFile f' >>= expandIncludes basedir' 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 -> ExceptT String IO CsvRules validateRules rules = do unless (isAssigned "date") $ ExceptT $ return $ Left "Please specify (at top level) the date field. Eg: date %1\n" unless ((amount && not (amountin || amountout)) || (not amount && (amountin && amountout))) $ ExceptT $ return $ Left "Please specify (at top level) either the amount field, or both the amount-in and amount-out fields. Eg: amount %2\n" ExceptT $ return $ Right rules where amount = isAssigned "amount" amountin = isAssigned "amount-in" amountout = isAssigned "amount-out" isAssigned f = isJust $ getEffectiveAssignment rules [] f -- parsers rulesp :: Stream [Char] m t => ParsecT [Char] CsvRules m CsvRules rulesp = do many $ choice' [blankorcommentline "blank or comment line" ,(directive >>= modifyState . addDirective) "directive" ,(fieldnamelist >>= modifyState . setIndexesAndAssignmentsFromList) "field name list" ,(fieldassignment >>= modifyState . addAssignment) "field assignment" ,(conditionalblock >>= modifyState . addConditionalBlock) "conditional block" ] eof r <- getState return r{rdirectives=reverse $ rdirectives r ,rassignments=reverse $ rassignments r ,rconditionalblocks=reverse $ rconditionalblocks r } blankorcommentline :: Stream [Char] m t => ParsecT [Char] CsvRules m () blankorcommentline = pdbg 3 "trying blankorcommentline" >> choice' [blankline, commentline] blankline :: Stream [Char] m t => ParsecT [Char] CsvRules m () blankline = many spacenonewline >> newline >> return () "blank line" commentline :: Stream [Char] m t => ParsecT [Char] CsvRules m () commentline = many spacenonewline >> commentchar >> restofline >> return () "comment line" commentchar :: Stream [Char] m t => ParsecT [Char] CsvRules m Char commentchar = oneOf ";#*" directive :: Stream [Char] m t => ParsecT [Char] CsvRules m (DirectiveName, String) directive = do pdbg 3 "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 :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char] directiveval = anyChar `manyTill` eolof fieldnamelist :: Stream [Char] m t => ParsecT [Char] CsvRules m [CsvFieldName] fieldnamelist = (do pdbg 3 "trying fieldnamelist" string "fields" optional $ char ':' many1 spacenonewline let separator = many spacenonewline >> char ',' >> many spacenonewline f <- fromMaybe "" <$> optionMaybe fieldname fs <- many1 $ (separator >> fromMaybe "" <$> optionMaybe fieldname) restofline return $ map (map toLower) $ f:fs ) "field name list" fieldname :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char] fieldname = quotedfieldname <|> barefieldname quotedfieldname :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char] quotedfieldname = do char '"' f <- many1 $ noneOf "\"\n:;#~" char '"' return f barefieldname :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char] barefieldname = many1 $ noneOf " \t\n,;#~" fieldassignment :: Stream [Char] m t => ParsecT [Char] CsvRules m (JournalFieldName, FieldTemplate) fieldassignment = do pdbg 3 "trying fieldassignment" f <- journalfieldname assignmentseparator v <- fieldval return (f,v) "field assignment" journalfieldname :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char] 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 :: Stream [Char] m t => ParsecT [Char] CsvRules m () assignmentseparator = do pdbg 3 "trying assignmentseparator" choice [ -- try (many spacenonewline >> oneOf ":="), try (many spacenonewline >> char ':'), space ] _ <- many spacenonewline return () fieldval :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char] fieldval = do pdbg 2 "trying fieldval" anyChar `manyTill` eolof conditionalblock :: Stream [Char] m t => ParsecT [Char] CsvRules m ConditionalBlock conditionalblock = do pdbg 3 "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 :: Stream [Char] m t => ParsecT [Char] CsvRules m [[Char]] 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 :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char] matchoperator = choice' $ map string ["~" -- ,"!~" -- ,"=" -- ,"!=" ] patterns :: Stream [Char] m t => ParsecT [Char] CsvRules m [[Char]] patterns = do pdbg 3 "trying patterns" ps <- many regexp return ps regexp :: Stream [Char] m t => ParsecT [Char] CsvRules m [Char] 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 :: SourcePos -> CsvRules -> CsvRecord -> Transaction transactionFromCsvRecord sourcepos 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 = case mfieldtemplate "status" of Nothing -> Uncleared Just str -> either statuserror id $ runParser (statusp <* eof) nullctx "" $ render str where statuserror err = error' $ unlines ["error: could not parse \""++str++"\" as a cleared status (should be *, ! or empty)" ,"the parse error is: "++show err ] 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 (amountp <* eof) 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{ tsourcepos = sourcepos, 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 :: RegexpPattern -> Bool patternMatches pat = regexMatchesCI 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 parsetime = #if MIN_VERSION_time(1,5,0) parseTimeM True #else parseTime #endif 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.26/Hledger/Read/JournalReader.hs0000644000000000000000000012444112550610364017333 0ustar0000000000000000-- {-# OPTIONS_GHC -F -pgmF htfpp #-} {-# LANGUAGE CPP, RecordWildCards, NoMonoLocalBinds, ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-| 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, datetimep, codep, accountnamep, modifiedaccountname, postingp, amountp, amountp', mamountp', numberp, statusp, emptyorcommentlinep, followingcommentp, accountaliasp -- * Tests ,tests_Hledger_Read_JournalReader #ifdef TESTS -- disabled by default, HTF not available on windows ,htf_thisModulesTests ,htf_Hledger_Read_JournalReader_importedTests #endif ) where import Prelude () import Prelude.Compat hiding (readFile) import qualified Control.Exception as C import Control.Monad.Compat import Control.Monad.Except (ExceptT(..), liftIO, runExceptT, throwError, catchError) import Data.Char (isNumber) import Data.List.Compat import Data.List.Split (wordsBy) import Data.Maybe import Data.Time.Calendar import Data.Time.LocalTime import Safe (headDef, lastDef) import Test.HUnit #ifdef TESTS import Test.Framework import Text.Parsec.Error #endif import Text.Parsec hiding (parse) import Text.Printf import System.FilePath import System.Time (getClockTime) import Hledger.Data import Hledger.Utils -- standard reader exports reader :: Reader reader = Reader format detect parse format :: String format = "journal" -- | Does the given file path and data look like it might be hledger's journal format ? detect :: FilePath -> String -> Bool detect f s | f /= "-" = takeExtension f `elem` ['.':format, ".j"] -- from a file: yes if the extension is .journal or .j -- from stdin: yes if we can see something that looks like a journal entry (digits in column 0 with the next line indented) | otherwise = regexMatches "^[0-9]+.*\n[ \t]+" s -- | Parse and post-process a "Journal" from hledger's journal file -- format, or give an error. parse :: Maybe FilePath -> Bool -> FilePath -> String -> ExceptT String IO Journal parse _ = parseJournalWith journal -- parsing utils -- | Flatten a list of JournalUpdate's into a single equivalent one. combineJournalUpdates :: [JournalUpdate] -> JournalUpdate combineJournalUpdates us = liftM (foldl' (\acc new x -> new (acc x)) 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 :: (ParsecT [Char] JournalContext (ExceptT String IO) (JournalUpdate,JournalContext)) -> Bool -> FilePath -> String -> ExceptT String IO Journal parseJournalWith p assrt f s = do tc <- liftIO getClockTime tl <- liftIO getCurrentLocalTime y <- liftIO getCurrentYear r <- runParserT p nullctx{ctxYear=Just y} f s case r of Right (updates,ctx) -> do j <- updates `ap` return nulljournal case journalFinalise tc tl f s ctx assrt j of Right j' -> return j' Left estr -> throwError estr Left e -> throwError $ show e setYear :: Stream [Char] m Char => Integer -> ParsecT [Char] JournalContext m () setYear y = modifyState (\ctx -> ctx{ctxYear=Just y}) getYear :: Stream [Char] m Char => ParsecT s JournalContext m (Maybe Integer) getYear = liftM ctxYear getState setDefaultCommodityAndStyle :: Stream [Char] m Char => (Commodity,AmountStyle) -> ParsecT [Char] JournalContext m () setDefaultCommodityAndStyle cs = modifyState (\ctx -> ctx{ctxDefaultCommodityAndStyle=Just cs}) getDefaultCommodityAndStyle :: Stream [Char] m Char => ParsecT [Char] JournalContext m (Maybe (Commodity,AmountStyle)) getDefaultCommodityAndStyle = ctxDefaultCommodityAndStyle `fmap` getState pushParentAccount :: Stream [Char] m Char => String -> ParsecT [Char] JournalContext m () pushParentAccount parent = modifyState addParentAccount where addParentAccount ctx0 = ctx0 { ctxAccount = parent : ctxAccount ctx0 } popParentAccount :: Stream [Char] m Char => ParsecT [Char] JournalContext m () popParentAccount = do ctx0 <- getState case ctxAccount ctx0 of [] -> unexpected "End of account block with no beginning" (_:rest) -> setState $ ctx0 { ctxAccount = rest } getParentAccount :: Stream [Char] m Char => ParsecT [Char] JournalContext m String getParentAccount = liftM (concatAccountNames . reverse . ctxAccount) getState addAccountAlias :: Stream [Char] m Char => AccountAlias -> ParsecT [Char] JournalContext m () addAccountAlias a = modifyState (\(ctx@Ctx{..}) -> ctx{ctxAliases=a:ctxAliases}) getAccountAliases :: Stream [Char] m Char => ParsecT [Char] JournalContext m [AccountAlias] getAccountAliases = liftM ctxAliases getState clearAccountAliases :: Stream [Char] m Char => ParsecT [Char] JournalContext m () clearAccountAliases = modifyState (\(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 :: ParsecT [Char] JournalContext (ExceptT String IO) (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 , emptyorcommentlinep >> return (return id) , multilinecommentp >> return (return id) ] "journal transaction or directive" -- cf http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives directive :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate directive = do optional $ char '!' choice' [ includedirective ,aliasdirective ,endaliasesdirective ,accountdirective ,enddirective ,tagdirective ,endtagdirective ,defaultyeardirective ,defaultcommoditydirective ,commodityconversiondirective ,ignoredpricecommoditydirective ] "directive" includedirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate includedirective = do string "include" many1 spacenonewline filename <- restofline outerState <- getState outerPos <- getPosition let curdir = takeDirectory (sourceName outerPos) let (u::ExceptT String IO (Journal -> Journal, JournalContext)) = do filepath <- expandPath curdir filename txt <- readFileOrError outerPos filepath let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n" r <- runParserT journal outerState filepath txt case r of Right (ju, ctx) -> do u <- combineJournalUpdates [ return $ journalAddFile (filepath,txt) , ju ] `catchError` (throwError . (inIncluded ++)) return (u, ctx) Left err -> throwError $ inIncluded ++ show err where readFileOrError pos fp = ExceptT $ liftM Right (readFile' fp) `C.catch` \e -> return $ Left $ printf "%s reading %s:\n%s" (show pos) fp (show (e::C.IOException)) r <- liftIO $ runExceptT u case r of Left err -> return $ throwError err Right (ju, _finalparsectx) -> return $ ExceptT $ return $ Right ju journalAddFile :: (FilePath,String) -> Journal -> Journal journalAddFile f j@Journal{files=fs} = j{files=fs++[f]} -- NOTE: first encountered file to left, to avoid a reverse accountdirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate accountdirective = do string "account" many1 spacenonewline parent <- accountnamep newline pushParentAccount parent -- return $ return id return $ ExceptT $ return $ Right id enddirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate enddirective = do string "end" popParentAccount -- return (return id) return $ ExceptT $ return $ Right id aliasdirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate aliasdirective = do string "alias" many1 spacenonewline alias <- accountaliasp addAccountAlias alias return $ return id accountaliasp :: Stream [Char] m Char => ParsecT [Char] st m AccountAlias accountaliasp = regexaliasp <|> basicaliasp basicaliasp :: Stream [Char] m Char => ParsecT [Char] st m AccountAlias basicaliasp = do -- pdbg 0 "basicaliasp" old <- rstrip <$> (many1 $ noneOf "=") char '=' many spacenonewline new <- rstrip <$> anyChar `manyTill` eolof -- don't require a final newline, good for cli options return $ BasicAlias old new regexaliasp :: Stream [Char] m Char => ParsecT [Char] st m AccountAlias regexaliasp = do -- pdbg 0 "regexaliasp" char '/' re <- many1 $ noneOf "/\n\r" -- paranoid: don't try to read past line end char '/' many spacenonewline char '=' many spacenonewline repl <- rstrip <$> anyChar `manyTill` eolof return $ RegexAlias re repl endaliasesdirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate endaliasesdirective = do string "end aliases" clearAccountAliases return (return id) tagdirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate tagdirective = do string "tag" "tag directive" many1 spacenonewline _ <- many1 nonspace restofline return $ return id endtagdirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate endtagdirective = do (string "end tag" <|> string "pop") "end tag or pop directive" restofline return $ return id defaultyeardirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate defaultyeardirective = do char 'Y' "default year" many spacenonewline y <- many1 digit let y' = read y failIfInvalidYear y setYear y' return $ return id defaultcommoditydirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate defaultcommoditydirective = do char 'D' "default commodity" many1 spacenonewline Amount{..} <- amountp setDefaultCommodityAndStyle (acommodity, astyle) restofline return $ return id historicalpricedirective :: ParsecT [Char] JournalContext (ExceptT String IO) HistoricalPrice historicalpricedirective = do char 'P' "historical price" many spacenonewline date <- try (do {LocalTime d _ <- datetimep; return d}) <|> datep -- a time is ignored many1 spacenonewline symbol <- commoditysymbol many spacenonewline price <- amountp restofline return $ HistoricalPrice date symbol price ignoredpricecommoditydirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate ignoredpricecommoditydirective = do char 'N' "ignored-price commodity" many1 spacenonewline commoditysymbol restofline return $ return id commodityconversiondirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate commodityconversiondirective = do char 'C' "commodity conversion" many1 spacenonewline amountp many spacenonewline char '=' many spacenonewline amountp restofline return $ return id modifiertransaction :: ParsecT [Char] JournalContext (ExceptT String IO) ModifierTransaction modifiertransaction = do char '=' "modifier transaction" many spacenonewline valueexpr <- restofline postings <- postings return $ ModifierTransaction valueexpr postings periodictransaction :: ParsecT [Char] JournalContext (ExceptT String IO) PeriodicTransaction periodictransaction = do char '~' "periodic transaction" many spacenonewline periodexpr <- restofline postings <- postings return $ PeriodicTransaction periodexpr postings -- | Parse a (possibly unbalanced) transaction. transaction :: ParsecT [Char] JournalContext (ExceptT String IO) Transaction transaction = do -- ptrace "transaction" sourcepos <- getPosition date <- datep "transaction" edate <- optionMaybe (secondarydatep date) "secondary date" lookAhead (spacenonewline <|> newline) "whitespace or newline" status <- statusp "cleared status" code <- codep "transaction code" description <- descriptionp >>= return . strip comment <- try followingcommentp <|> (newline >> return "") let tags = tagsInComment comment postings <- postings return $ txnTieKnot $ Transaction sourcepos 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=Uncleared, tcode="code", tdescription="desc", tcomment=" tcomment1\n tcomment2\n ttag1: val1\n", ttags=[("ttag1","val1")], tpostings=[ nullposting{ pstatus=Cleared, 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="" } unlines [ "2015/1/1", ] `gives` nulltransaction{ tdate=parsedate "2015/01/01", } 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. -- Hyphen (-) and period (.) are also allowed as separators. -- The year may be omitted if a default year has been set. -- Leading zeroes may be omitted. datep :: Stream [Char] m t => ParsecT [Char] JournalContext m Day datep = 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 sepchars = nub $ sort $ filter (`elem` datesepchars) datestr when (length sepchars /= 1) $ fail $ "bad date, different separators used: " ++ datestr 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. -- Hyphen (-) and period (.) are also allowed as date separators. -- The year may be omitted if a default year has been set. -- Seconds are optional. -- The timezone is optional and ignored (the time is always interpreted as a local time). -- Leading zeroes may be omitted (except in a timezone). datetimep :: Stream [Char] m Char => ParsecT [Char] JournalContext m LocalTime datetimep = do day <- datep 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') secondarydatep :: Stream [Char] m Char => Day -> ParsecT [Char] JournalContext m Day secondarydatep 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 datep return edate statusp :: Stream [Char] m Char => ParsecT [Char] JournalContext m ClearedStatus statusp = choice' [ many spacenonewline >> char '*' >> return Cleared , many spacenonewline >> char '!' >> return Pending , return Uncleared ] "cleared status" codep :: Stream [Char] m Char => ParsecT [Char] JournalContext m String codep = try (do { many1 spacenonewline; char '(' "codep"; code <- anyChar `manyTill` char ')'; return code } ) <|> return "" -- Parse the following whitespace-beginning lines as postings, posting tags, and/or comments. postings :: Stream [Char] m Char => ParsecT [Char] JournalContext m [Posting] postings = many (try postingp) "postings" -- linebeginningwithspaces :: Stream [Char] m Char => ParsecT [Char] JournalContext m String -- linebeginningwithspaces = do -- sp <- many1 spacenonewline -- c <- nonspace -- cs <- restofline -- return $ sp ++ (c:cs) ++ "\n" postingp :: Stream [Char] m Char => ParsecT [Char] JournalContext m Posting postingp = do many1 spacenonewline status <- statusp many spacenonewline account <- modifiedaccountname let (ptype, account') = (accountNamePostingType account, unbracket account) amount <- spaceandamountormissing massertion <- partialbalanceassertion _ <- fixedlotprice many spacenonewline ctx <- getState comment <- try followingcommentp <|> (newline >> return "") let tags = tagsInComment comment -- oh boy date <- case dateValueFromTags tags of Nothing -> return Nothing Just v -> case runParser (datep <* eof) ctx "" v of Right d -> return $ Just d Left err -> parserFail $ show err date2 <- case date2ValueFromTags tags of Nothing -> return Nothing Just v -> case runParser (datep <* eof) ctx "" v of Right d -> return $ Just d Left err -> parserFail $ show err return posting { pdate=date , pdate2=date2 , 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 :: Stream [Char] m Char => ParsecT [Char] JournalContext m AccountName modifiedaccountname = do a <- accountnamep prefix <- getParentAccount let prefixed = prefix `joinAccountNames` a aliases <- getAccountAliases return $ accountNameApplyAliases aliases prefixed -- | Parse an account name. Account names start with a non-space, may -- have single spaces inside them, and are terminated by two or more -- spaces (or end of input). Also they have one or more components of -- at least one character, separated by the account separator char. -- (This parser will also consume one following space, if present.) accountnamep :: Stream [Char] m Char => ParsecT [Char] st m AccountName accountnamep = do a <- do c <- nonspace cs <- striptrailingspace <$> many (nonspace <|> singlespace) return $ c:cs when (accountNameFromComponents (accountNameComponents a) /= a) (fail $ "account name seems ill-formed: "++a) return a where singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}}) striptrailingspace "" = "" 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 :: Stream [Char] m Char => ParsecT [Char] JournalContext m 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 :: Stream [Char] m t => ParsecT [Char] JournalContext m 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 = case runParser (amountp <* eof) nullctx "" s of Right t -> t Left err -> error' $ show err -- | Parse a mixed amount from a string, or get an error. mamountp' :: String -> MixedAmount mamountp' = Mixed . (:[]) . amountp' signp :: Stream [Char] m t => ParsecT [Char] JournalContext m String signp = do sign <- optionMaybe $ oneOf "+-" return $ case sign of Just '-' -> "-" _ -> "" leftsymbolamount :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount leftsymbolamount = do sign <- signp c <- commoditysymbol sp <- many spacenonewline (q,prec,mdec,mgrps) <- numberp let s = amountstyle{ascommodityside=L, ascommodityspaced=not $ null sp, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps} p <- priceamount let applysign = if sign=="-" then negate else id return $ applysign $ Amount c q p s "left-symbol amount" rightsymbolamount :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount rightsymbolamount = do (q,prec,mdec,mgrps) <- numberp sp <- many spacenonewline c <- commoditysymbol p <- priceamount let s = amountstyle{ascommodityside=R, ascommodityspaced=not $ null sp, asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps} return $ Amount c q p s "right-symbol amount" nosymbolamount :: Stream [Char] m t => ParsecT [Char] JournalContext m Amount nosymbolamount = do (q,prec,mdec,mgrps) <- numberp p <- priceamount -- apply the most recently seen default commodity and style to this commodityless amount defcs <- getDefaultCommodityAndStyle let (c,s) = case defcs of Just (defc,defs) -> (defc, defs{asprecision=max (asprecision defs) prec}) Nothing -> ("", amountstyle{asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps}) return $ Amount c q p s "no-symbol amount" commoditysymbol :: Stream [Char] m t => ParsecT [Char] JournalContext m String commoditysymbol = (quotedcommoditysymbol <|> simplecommoditysymbol) "commodity symbol" quotedcommoditysymbol :: Stream [Char] m t => ParsecT [Char] JournalContext m String quotedcommoditysymbol = do char '"' s <- many1 $ noneOf ";\n\"" char '"' return s simplecommoditysymbol :: Stream [Char] m t => ParsecT [Char] JournalContext m String simplecommoditysymbol = many1 (noneOf nonsimplecommoditychars) priceamount :: Stream [Char] m t => ParsecT [Char] JournalContext m 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 partialbalanceassertion :: Stream [Char] m t => ParsecT [Char] JournalContext m (Maybe MixedAmount) partialbalanceassertion = try (do many spacenonewline char '=' many spacenonewline a <- amountp -- XXX should restrict to a simple amount return $ Just $ Mixed [a]) <|> return Nothing -- balanceassertion :: Stream [Char] m Char => ParsecT [Char] JournalContext m (Maybe MixedAmount) -- balanceassertion = -- try (do -- many spacenonewline -- string "==" -- 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 :: Stream [Char] m Char => ParsecT [Char] JournalContext m (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 string representation of a number for its value and display -- attributes. -- -- Some international number formats are accepted, eg 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. See -- http://en.wikipedia.org/wiki/Decimal_separator for more examples. -- -- This returns: the parsed numeric value, the precision (number of digits -- seen following the decimal point), the decimal point character used if any, -- and the digit group style if any. -- numberp :: Stream [Char] m t => ParsecT [Char] JournalContext m (Quantity, Int, Maybe Char, Maybe DigitGroupStyle) numberp = do -- a number is an optional sign followed by a sequence of digits possibly -- interspersed with periods, commas, or both -- ptrace "numberp" sign <- signp parts <- many1 $ choice' [many1 digit, many1 $ char ',', many1 $ char '.'] dbg8 "numberp parsed" (sign,parts) `seq` return () -- check the number is well-formed and identify the decimal point and digit -- group separator characters used, if any let (numparts, puncparts) = partition numeric parts (ok, mdecimalpoint, mseparator) = case (numparts, puncparts) of ([],_) -> (False, Nothing, Nothing) -- no digits, not ok (_,[]) -> (True, Nothing, Nothing) -- digits with no punctuation, ok (_,[[d]]) -> (True, Just d, Nothing) -- just a single punctuation of length 1, assume it's a decimal point (_,[_]) -> (False, Nothing, Nothing) -- a single punctuation of some other length, not ok (_,_:_:_) -> -- two or more punctuations let (s:ss, d) = (init puncparts, last puncparts) -- the leftmost is a separator and the rightmost may be a decimal point in if (any ((/=1).length) puncparts -- adjacent punctuation chars, not ok || any (s/=) ss -- separator chars vary, 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 - must be separators else (True, Just $ head d, Just $ head s) -- separator(s) and a decimal point when (not ok) (fail $ "number seems ill-formed: "++concat parts) -- get the digit group sizes and digit group style if any let (intparts',fracparts') = span ((/= mdecimalpoint) . Just . head) parts (intparts, fracpart) = (filter numeric intparts', filter numeric fracparts') groupsizes = reverse $ case map length intparts of (a:b:cs) | a < b -> b:cs gs -> gs mgrps = maybe Nothing (Just . (`DigitGroups` groupsizes)) $ mseparator -- put the parts back together without digit group separators, get the precision and parse the value let 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 quantity = read $ sign++int'++"."++frac' -- this read should never fail return $ dbg8 "numberp quantity,precision,mdecimalpoint,mgrps" (quantity,precision,mdecimalpoint,mgrps) "numberp" where numeric = isNumber . headDef '_' -- test_numberp = do -- let s `is` n = assertParseEqual (parseWithCtx nullctx numberp s) n -- assertFails = assertBool . isLeft . parseWithCtx nullctx numberp -- 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." -- comment parsers multilinecommentp :: Stream [Char] m Char => ParsecT [Char] JournalContext m () multilinecommentp = do string "comment" >> many spacenonewline >> newline go where go = try (string "end comment" >> newline >> return ()) <|> (anyLine >> go) anyLine = anyChar `manyTill` newline emptyorcommentlinep :: Stream [Char] m Char => ParsecT [Char] JournalContext m () emptyorcommentlinep = do many spacenonewline >> (comment <|> (many spacenonewline >> newline >> return "")) return () followingcommentp :: Stream [Char] m Char => ParsecT [Char] JournalContext m String followingcommentp = -- ptrace "followingcommentp" do samelinecomment <- many spacenonewline >> (try semicoloncomment <|> (newline >> return "")) newlinecomments <- many (try (many1 spacenonewline >> semicoloncomment)) return $ unlines $ samelinecomment:newlinecomments comment :: Stream [Char] m Char => ParsecT [Char] JournalContext m String comment = commentStartingWith commentchars commentchars :: [Char] commentchars = "#;*" semicoloncomment :: Stream [Char] m Char => ParsecT [Char] JournalContext m String semicoloncomment = commentStartingWith ";" commentStartingWith :: Stream [Char] m Char => String -> ParsecT [Char] JournalContext m String commentStartingWith cs = do -- ptrace "commentStartingWith" oneOf cs 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 runParser (tag <* eof) nullctx "" 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 tests_Hledger_Read_JournalReader = TestList $ concat [ -- test_numberp ] {- old hunit tests tests_Hledger_Read_JournalReader = TestList $ concat [ test_numberp, test_amountp, test_spaceandamountormissing, test_tagcomment, test_inlinecomment, test_comments, 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") ,"comment" ~: do assertParse (parseWithCtx nullctx comment "; some comment \n") assertParse (parseWithCtx nullctx comment " \t; x\n") assertParse (parseWithCtx nullctx comment "#x") ,"datep" ~: do assertParse (parseWithCtx nullctx datep "2011/1/1") assertParseFailure (parseWithCtx nullctx datep "1/1") assertParse (parseWithCtx nullctx{ctxYear=Just 2011} datep "1/1") ,"datetimep" ~: do let p = do {t <- datetimep; 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") ,"accountnamep" ~: do assertBool "accountnamep parses a normal account name" (isRight $ parsewith accountnamep "a:b:c") assertBool "accountnamep rejects an empty inner component" (isLeft $ parsewith accountnamep "a::c") assertBool "accountnamep rejects an empty leading component" (isLeft $ parsewith accountnamep ":b:c") assertBool "accountnamep rejects an empty trailing component" (isLeft $ parsewith accountnamep "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.26/Hledger/Read/TimelogReader.hs0000644000000000000000000000757712550610364017333 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 Prelude () import Prelude.Compat import Control.Monad (liftM) import Control.Monad.Except (ExceptT) import Data.List (isPrefixOf, foldl') import Data.Maybe (fromMaybe) import Test.HUnit import Text.Parsec hiding (parse) import System.FilePath import Hledger.Data -- XXX too much reuse ? import Hledger.Read.JournalReader ( directive, historicalpricedirective, defaultyeardirective, emptyorcommentlinep, datetimep, parseJournalWith, modifiedaccountname ) import Hledger.Utils reader :: Reader reader = Reader format detect parse format :: String format = "timelog" -- | Does the given file path and data look like it might be timeclock.el's timelog format ? detect :: FilePath -> String -> Bool detect f s | f /= "-" = takeExtension f == '.':format -- from a file: yes if the extension is .timelog | otherwise = "i " `isPrefixOf` s || "o " `isPrefixOf` s -- from stdin: yes if it starts with "i " or "o " -- | 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 -> Bool -> FilePath -> String -> ExceptT String IO Journal parse _ = parseJournalWith timelogFile timelogFile :: ParsecT [Char] JournalContext (ExceptT String IO) (JournalUpdate, JournalContext) timelogFile = do items <- many timelogItem eof ctx <- getState return (liftM (foldl' (\acc new x -> new (acc x)) 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 , emptyorcommentlinep >> return (return id) , liftM (return . addTimeLogEntry) timelogentry ] "timelog entry, or default year or historical price directive" -- | Parse a timelog entry. timelogentry :: ParsecT [Char] JournalContext (ExceptT String IO) TimeLogEntry timelogentry = do sourcepos <- getPosition code <- oneOf "bhioO" many1 spacenonewline datetime <- datetimep account <- fromMaybe "" <$> optionMaybe (many1 spacenonewline >> modifiedaccountname) description <- fromMaybe "" <$> optionMaybe (many1 spacenonewline >> restofline) return $ TimeLogEntry sourcepos (read [code]) datetime account description tests_Hledger_Read_TimelogReader = TestList [ ] hledger-lib-0.26/Hledger/Reports/0000755000000000000000000000000012550610364015017 5ustar0000000000000000hledger-lib-0.26/Hledger/Reports/BalanceHistoryReport.hs0000644000000000000000000000171512550610364021462 0ustar0000000000000000{-# LANGUAGE RecordWildCards, DeriveDataTypeable, FlexibleInstances #-} {-| Account balance history report. -} module Hledger.Reports.BalanceHistoryReport ( accountBalanceHistory -- -- * Tests -- tests_Hledger_Reports_BalanceReport ) where import Data.Time.Calendar -- import Test.HUnit import Hledger.Data import Hledger.Query import Hledger.Reports.ReportOptions import Hledger.Reports.TransactionsReports -- | Get the historical running inclusive balance of a particular account, -- from earliest to latest posting date. 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 hledger-lib-0.26/Hledger/Reports/BalanceReport.hs0000644000000000000000000003323112550610364020076 0ustar0000000000000000{-# LANGUAGE RecordWildCards, DeriveDataTypeable, FlexibleInstances, ScopedTypeVariables #-} {-| Balance report, used by the balance command. -} module Hledger.Reports.BalanceReport ( BalanceReport, BalanceReportItem, RenderableAccountName, balanceReport, flatShowsExclusiveBalance, -- * Tests tests_Hledger_Reports_BalanceReport ) where import Data.Maybe import Test.HUnit import Hledger.Data import Hledger.Read (mamountp') import Hledger.Query import Hledger.Utils import Hledger.Reports.ReportOptions -- | A simple single-column balance report. It has: -- -- 1. a list of rows, each containing a renderable account name and a corresponding amount -- -- 2. the final total of the amounts type BalanceReport = ([BalanceReportItem], MixedAmount) type BalanceReportItem = (RenderableAccountName, MixedAmount) -- | A renderable account name includes some additional hints for rendering accounts in a balance report. -- It has: -- -- * The full account name -- -- * The ledger-style short elided account name (the leaf name, prefixed by any boring parents immediately above) -- -- * The number of indentation steps to use when rendering a ledger-style account tree -- (normally the 0-based depth of this account excluding boring parents, or 0 with --flat). type RenderableAccountName = (AccountName, AccountName, Int) -- | When true (the default), this makes balance --flat reports and their implementation clearer. -- Single/multi-col balance reports currently aren't all correct if this is false. flatShowsExclusiveBalance = True -- | Enabling this makes balance --flat --empty also show parent accounts without postings, -- in addition to those with postings and a zero balance. Disabling it shows only the latter. -- No longer supported, but leave this here for a bit. -- flatShowsPostinglessAccounts = True -- | Generate a simple balance report, containing the matched accounts and -- their balances (change of balance) during the specified period. -- This is like periodBalanceReport with a single column (but more mature, -- eg this can do hierarchical display). balanceReport :: ReportOpts -> Query -> Journal -> BalanceReport balanceReport opts q j = (items, total) where -- dbg1 = const id -- exclude from debug output dbg1 s = let p = "balanceReport" in Hledger.Utils.dbg1 (p++" "++s) -- add prefix in debug output accts = ledgerRootAccount $ ledgerFromJournal q $ journalSelectingAmountFromOpts opts j accts' :: [Account] | queryDepth q == 0 = dbg1 "accts" $ take 1 $ clipAccountsAndAggregate (queryDepth q) $ flattenAccounts accts | flat_ opts = dbg1 "accts" $ filterzeros $ filterempty $ drop 1 $ clipAccountsAndAggregate (queryDepth q) $ flattenAccounts accts | otherwise = dbg1 "accts" $ filter (not.aboring) $ drop 1 $ flattenAccounts $ markboring $ prunezeros $ clipAccounts (queryDepth q) accts where balance = if flat_ opts then aebalance else aibalance filterzeros = if empty_ opts then id else filter (not . isZeroMixedAmount . balance) filterempty = filter (\a -> anumpostings a > 0 || not (isZeroMixedAmount (balance a))) prunezeros = if empty_ opts then id else fromMaybe nullacct . pruneAccounts (isZeroMixedAmount . balance) markboring = if no_elide_ opts then id else markBoringParentAccounts items = dbg1 "items" $ map (balanceReportItem opts q) accts' total | not (flat_ opts) = dbg1 "total" $ sum [amt | ((_,_,indent),amt) <- items, indent == 0] | otherwise = dbg1 "total" $ if flatShowsExclusiveBalance then sum $ map snd items else sum $ map aebalance $ clipAccountsAndAggregate 1 accts' -- | 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 -> Query -> Account -> BalanceReportItem balanceReportItem opts q a | flat_ opts = ((name, name, 0), (if flatShowsExclusiveBalance then aebalance else aibalance) a) | otherwise = ((name, elidedname, indent), aibalance a) where name | queryDepth q > 0 = aname a | otherwise = "..." elidedname = accountNameFromComponents (adjacentboringparentnames ++ [accountLeafName name]) adjacentboringparentnames = reverse $ map (accountLeafName.aname) $ takeWhile aboring $ parents indent = length $ filter (not.aboring) parents -- parents exclude the tree's root node parents = case parentAccounts a of [] -> [] as -> init as -- -- the above using the newer multi balance report code: -- balanceReport' opts q j = (items, total) -- where -- MultiBalanceReport (_,mbrrows,mbrtotals) = periodBalanceReport opts q j -- items = [(a,a',n, headDef 0 bs) | ((a,a',n), bs) <- mbrrows] -- total = headDef 0 mbrtotals tests_balanceReport = let (opts,journal) `gives` r = do let (eitems, etotal) = r (aitems, atotal) = balanceReport opts (queryFromOpts nulldate opts) journal showw (acct,amt) = (acct, showMixedAmountDebug amt) assertEqual "items" (map showw eitems) (map showw aitems) assertEqual "total" (showMixedAmountDebug etotal) (showMixedAmountDebug atotal) usd0 = nullamt{acommodity="$"} 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 [usd0]) ,"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 [usd0]) ,"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 [usd0]) ,"balanceReport with a date or secondary date span" ~: do (defreportopts{query_="date:'in 2009'"}, samplejournal2) `gives` ([], Mixed [nullamt]) (defreportopts{query_="date2:'in 2009'"}, samplejournal2) `gives` ([ (("assets:bank:checking","assets:bank:checking",0),mamountp' "$1.00") ,(("income:salary","income:salary",0),mamountp' "$-1.00") ], Mixed [usd0]) ,"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 [usd0]) ,"balanceReport with not:desc:" ~: do (defreportopts{query_="not:desc:income"}, samplejournal) `gives` ([ (("assets","assets",0), mamountp' "$-2.00") ,(("assets:bank","bank",1), Mixed [usd0]) ,(("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 [usd0]) {- ,"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 { tsourcepos=nullsourcepos, tdate=parsedate "2008/01/01", tdate2=Just $ parsedate "2009/01/01", tstatus=Uncleared, 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_BalanceReport :: Test tests_Hledger_Reports_BalanceReport = TestList $ tests_balanceReport hledger-lib-0.26/Hledger/Reports/EntriesReport.hs0000644000000000000000000000263612550610364020167 0ustar0000000000000000{-# LANGUAGE RecordWildCards, DeriveDataTypeable, FlexibleInstances #-} {-| Journal entries report, used by the print command. -} module Hledger.Reports.EntriesReport ( EntriesReport, EntriesReportItem, entriesReport, -- * Tests tests_Hledger_Reports_EntriesReport ) where import Data.List import Data.Ord import Test.HUnit import Hledger.Data import Hledger.Query import Hledger.Reports.ReportOptions -- | 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 :: [Test] tests_entriesReport = [ "entriesReport" ~: do assertEqual "not acct" 1 (length $ entriesReport defreportopts (Not $ Acct "bank") samplejournal) let sp = mkdatespan "2008/06/01" "2008/07/01" assertEqual "date" 3 (length $ entriesReport defreportopts (Date sp) samplejournal) ] tests_Hledger_Reports_EntriesReport :: Test tests_Hledger_Reports_EntriesReport = TestList $ tests_entriesReport hledger-lib-0.26/Hledger/Reports/MultiBalanceReports.hs0000644000000000000000000002106412550610364021275 0ustar0000000000000000{-# LANGUAGE RecordWildCards, DeriveDataTypeable, FlexibleInstances, ScopedTypeVariables #-} {-| Multi-column balance reports, used by the balance command. -} module Hledger.Reports.MultiBalanceReports ( MultiBalanceReport(..), MultiBalanceReportRow, multiBalanceReport -- -- * Tests -- tests_Hledger_Reports_MultiBalanceReport ) where import Data.List import Data.Maybe import Data.Ord import Safe -- import Test.HUnit import Hledger.Data import Hledger.Query import Hledger.Utils import Hledger.Reports.ReportOptions import Hledger.Reports.BalanceReport -- | A multi balance report is a balance report with one or more columns. It has: -- -- 1. a list of each column's date span -- -- 2. a list of rows, each containing a renderable account name and the amounts to show in each column -- -- 3. a list of each column's final total -- -- The meaning of the amounts depends on the type of multi balance -- report, of which there are three: periodic, cumulative and historical -- (see 'BalanceType' and "Hledger.Cli.Balance"). newtype MultiBalanceReport = MultiBalanceReport ([DateSpan] ,[MultiBalanceReportRow] ,MultiBalanceTotalsRow ) -- | A row in a multi balance report has -- -- * An account name, with rendering hints -- -- * A list of amounts to be shown in each of the report's columns. -- -- * The total of the row amounts. -- -- * The average of the row amounts. type MultiBalanceReportRow = (RenderableAccountName, [MixedAmount], MixedAmount, MixedAmount) type MultiBalanceTotalsRow = ([MixedAmount], MixedAmount, MixedAmount) instance Show MultiBalanceReport where -- use ppShow to break long lists onto multiple lines -- we 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) -- type alias just to remind us which AccountNames might be depth-clipped, below. type ClippedAccountName = AccountName -- | Generate a multicolumn balance report for the matched accounts, -- showing the change of balance, accumulated balance, or historical balance -- in each of the specified periods. multiBalanceReport :: ReportOpts -> Query -> Journal -> MultiBalanceReport multiBalanceReport opts q j = MultiBalanceReport (displayspans, items, totalsrow) where symq = dbg1 "symq" $ filterQuery queryIsSym $ dbg1 "requested q" q depthq = dbg1 "depthq" $ filterQuery queryIsDepth q depth = queryDepth depthq depthless = dbg1 "depthless" . filterQuery (not . queryIsDepth) datelessq = dbg1 "datelessq" $ filterQuery (not . queryIsDateOrDate2) q dateqcons = if date2_ opts then Date2 else Date precedingq = dbg1 "precedingq" $ And [datelessq, dateqcons $ DateSpan Nothing (spanStart reportspan)] requestedspan = dbg1 "requestedspan" $ queryDateSpan (date2_ opts) q -- span specified by -b/-e/-p options and query args requestedspan' = dbg1 "requestedspan'" $ requestedspan `spanDefaultsFrom` journalDateSpan (date2_ opts) j -- if open-ended, close it using the journal's end dates intervalspans = dbg1 "intervalspans" $ splitSpan (intervalFromOpts opts) requestedspan' -- interval spans enclosing it reportspan = dbg1 "reportspan" $ DateSpan (maybe Nothing spanStart $ headMay intervalspans) -- the requested span enlarged to a whole number of intervals (maybe Nothing spanEnd $ lastMay intervalspans) newdatesq = dbg1 "newdateq" $ dateqcons reportspan reportq = dbg1 "reportq" $ depthless $ And [datelessq, newdatesq] -- user's query enlarged to whole intervals and with no depth limit ps :: [Posting] = dbg1 "ps" $ journalPostings $ filterJournalAmounts symq $ -- remove amount parts excluded by cur: filterJournalPostings reportq $ -- remove postings not matched by (adjusted) query journalSelectingAmountFromOpts opts j displayspans = dbg1 "displayspans" $ splitSpan (intervalFromOpts opts) displayspan where displayspan | empty_ opts = dbg1 "displayspan (-E)" $ reportspan -- all the requested intervals | otherwise = dbg1 "displayspan" $ requestedspan `spanIntersect` matchedspan -- exclude leading/trailing empty intervals matchedspan = dbg1 "matchedspan" $ postingsDateSpan' (whichDateFromOpts opts) ps psPerSpan :: [[Posting]] = dbg1 "psPerSpan" $ [filter (isPostingInDateSpan' (whichDateFromOpts opts) s) ps | s <- displayspans] postedAcctBalChangesPerSpan :: [[(ClippedAccountName, MixedAmount)]] = dbg1 "postedAcctBalChangesPerSpan" $ map postingAcctBals psPerSpan where postingAcctBals :: [Posting] -> [(ClippedAccountName, MixedAmount)] postingAcctBals ps = [(aname a, (if tree_ opts then aibalance else aebalance) a) | a <- as] where as = depthLimit $ (if tree_ opts then id else filter ((>0).anumpostings)) $ drop 1 $ accountsFromPostings ps depthLimit | tree_ opts = filter ((depthq `matchesAccount`).aname) -- exclude deeper balances | otherwise = clipAccountsAndAggregate depth -- aggregate deeper balances at the depth limit postedAccts :: [AccountName] = dbg1 "postedAccts" $ sort $ accountNamesFromPostings ps -- starting balances and accounts from transactions before the report start date startacctbals = dbg1 "startacctbals" $ map (\((a,_,_),b) -> (a,b)) startbalanceitems where (startbalanceitems,_) = dbg1 "starting balance report" $ balanceReport opts' precedingq j where opts' | tree_ opts = opts{no_elide_=True} | otherwise = opts{accountlistmode_=ALFlat} startingBalanceFor a = fromMaybe nullmixedamt $ lookup a startacctbals startAccts = dbg1 "startAccts" $ map fst startacctbals displayedAccts :: [ClippedAccountName] = dbg1 "displayedAccts" $ (if tree_ opts then expandAccountNames else id) $ nub $ map (clipOrEllipsifyAccountName depth) $ if empty_ opts then nub $ sort $ startAccts ++ postedAccts else postedAccts acctBalChangesPerSpan :: [[(ClippedAccountName, MixedAmount)]] = dbg1 "acctBalChangesPerSpan" $ [sortBy (comparing fst) $ unionBy (\(a,_) (a',_) -> a == a') postedacctbals zeroes | postedacctbals <- postedAcctBalChangesPerSpan] where zeroes = [(a, nullmixedamt) | a <- displayedAccts] acctBalChanges :: [(ClippedAccountName, [MixedAmount])] = dbg1 "acctBalChanges" $ [(a, map snd abs) | abs@((a,_):_) <- transpose acctBalChangesPerSpan] -- never null, or used when null... items :: [MultiBalanceReportRow] = dbg1 "items" $ [((a, accountLeafName a, accountNameLevel a), displayedBals, rowtot, rowavg) | (a,changes) <- acctBalChanges , let displayedBals = case balancetype_ opts of HistoricalBalance -> drop 1 $ scanl (+) (startingBalanceFor a) changes CumulativeBalance -> drop 1 $ scanl (+) nullmixedamt changes _ -> changes , let rowtot = sum displayedBals , let rowavg = averageMixedAmounts displayedBals , empty_ opts || depth == 0 || any (not . isZeroMixedAmount) displayedBals ] totals :: [MixedAmount] = -- dbg1 "totals" $ map sum balsbycol where balsbycol = transpose [bs | ((a,_,_),bs,_,_) <- items, not (tree_ opts) || a `elem` highestlevelaccts] highestlevelaccts = dbg1 "highestlevelaccts" $ [a | a <- displayedAccts, not $ any (`elem` displayedAccts) $ init $ expandAccountName a] totalsrow :: MultiBalanceTotalsRow = dbg1 "totalsrow" $ (totals, sum totals, averageMixedAmounts totals) dbg1 s = let p = "multiBalanceReport" in Hledger.Utils.dbg1 (p++" "++s) -- add prefix in this function's debug output -- dbg1 = const id -- exclude this function from debug output hledger-lib-0.26/Hledger/Reports/PostingsReport.hs0000644000000000000000000005236012550610364020363 0ustar0000000000000000{-# LANGUAGE RecordWildCards, DeriveDataTypeable, FlexibleInstances, TupleSections #-} {-| Postings report, used by the register command. -} module Hledger.Reports.PostingsReport ( PostingsReport, PostingsReportItem, postingsReport, mkpostingsReportItem, -- * Tests tests_Hledger_Reports_PostingsReport ) where import Data.List import Data.Maybe import Data.Ord (comparing) import Data.Time.Calendar import Safe (headMay, lastMay) import Test.HUnit import Hledger.Data import Hledger.Query import Hledger.Utils import Hledger.Reports.ReportOptions -- | 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 -- The posting date, if this is the first posting in a -- transaction or if it's different from the previous -- posting's date. Or if this a summary posting, the -- report interval's start date if this is the first -- summary posting in the interval. ,Maybe Day -- If this is a summary posting, the report interval's -- end date if this is the first summary posting in -- the interval. ,Maybe String -- The posting's transaction's description, if this is the first posting in the transaction. ,Posting -- The posting, possibly with the 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 = (totallabel, items) where -- figure out adjusted queries & spans like multiBalanceReport symq = dbg1 "symq" $ filterQuery queryIsSym $ dbg1 "requested q" q depth = queryDepth q depthless = filterQuery (not . queryIsDepth) datelessq = filterQuery (not . queryIsDateOrDate2) q -- XXX date:/date2:/--date2 handling is not robust, combinations of these can confuse it dateq = filterQuery queryIsDateOrDate2 q (dateqcons,pdate) | queryIsDate2 dateq || (queryIsDate dateq && date2_ opts) = (Date2, postingDate2) | otherwise = (Date, postingDate) requestedspan = dbg1 "requestedspan" $ queryDateSpan' q -- span specified by -b/-e/-p options and query args requestedspan' = dbg1 "requestedspan'" $ requestedspan `spanDefaultsFrom` journalDateSpan ({-date2_ opts-} False) j -- if open-ended, close it using the journal's end dates intervalspans = dbg1 "intervalspans" $ splitSpan (intervalFromOpts opts) requestedspan' -- interval spans enclosing it reportstart = dbg1 "reportstart" $ maybe Nothing spanStart $ headMay intervalspans reportend = dbg1 "reportend" $ maybe Nothing spanEnd $ lastMay intervalspans reportspan = dbg1 "reportspan" $ DateSpan reportstart reportend -- the requested span enlarged to a whole number of intervals beforestartq = dbg1 "beforestartq" $ dateqcons $ DateSpan Nothing reportstart beforeendq = dbg1 "beforeendq" $ dateqcons $ DateSpan Nothing reportend reportq = dbg1 "reportq" $ depthless $ And [datelessq, beforeendq] -- user's query with no start date, end date on an interval boundary and no depth limit pstoend = dbg1 "ps4" $ sortBy (comparing pdate) $ -- sort postings by date (or date2) dbg1 "ps3" $ map (filterPostingAmount symq) $ -- remove amount parts which the query's cur: terms would exclude dbg1 "ps2" $ (if related_ opts then concatMap relatedPostings else id) $ -- with -r, replace each with its sibling postings dbg1 "ps1" $ filter (reportq `matchesPosting`) $ -- filter postings by the query, including before the report start date, ignoring depth journalPostings $ journalSelectingAmountFromOpts opts j (precedingps, reportps) = dbg1 "precedingps, reportps" $ span (beforestartq `matchesPosting`) pstoend showempty = empty_ opts || average_ opts -- displayexpr = display_ opts -- XXX interval = intervalFromOpts opts -- XXX whichdate = whichDateFromOpts opts itemps | interval == NoInterval = map (,Nothing) reportps | otherwise = summarisePostingsByInterval interval whichdate depth showempty reportspan reportps items = dbg1 "items" $ postingsReportItems itemps (nullposting,Nothing) whichdate depth startbal runningcalc 1 where startbal = if balancetype_ opts == HistoricalBalance then sumPostings precedingps else 0 runningcalc | average_ opts = \i avg amt -> avg + (amt - avg) `divideMixedAmount` (fromIntegral i) -- running average | otherwise = \_ bal amt -> bal + amt -- running total dbg1 s = let p = "postingsReport" in Hledger.Utils.dbg1 (p++" "++s) -- add prefix in debug output -- dbg1 = const id -- exclude from debug output totallabel = "Total" -- | Generate postings report line items from a list of postings or (with -- non-Nothing dates attached) summary postings. postingsReportItems :: [(Posting,Maybe Day)] -> (Posting,Maybe Day) -> WhichDate -> Int -> MixedAmount -> (Int -> MixedAmount -> MixedAmount -> MixedAmount) -> Int -> [PostingsReportItem] postingsReportItems [] _ _ _ _ _ _ = [] postingsReportItems ((p,menddate):ps) (pprev,menddateprev) wd d b runningcalcfn itemnum = i:(postingsReportItems ps (p,menddate) wd d b' runningcalcfn (itemnum+1)) where i = mkpostingsReportItem showdate showdesc wd menddate p' b' (showdate, showdesc) | isJust menddate = (menddate /= menddateprev, False) | otherwise = (isfirstintxn || isdifferentdate, isfirstintxn) isfirstintxn = ptransaction p /= ptransaction pprev isdifferentdate = case wd of PrimaryDate -> postingDate p /= postingDate pprev SecondaryDate -> postingDate2 p /= postingDate2 pprev p' = p{paccount= clipOrEllipsifyAccountName 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 -> Maybe Day -> Posting -> MixedAmount -> PostingsReportItem mkpostingsReportItem showdate showdesc wd menddate p b = (if showdate then Just date else Nothing ,menddate ,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 -- | Convert a list of postings into summary postings, one per interval, -- aggregated to the specified depth if any. summarisePostingsByInterval :: Interval -> WhichDate -> Int -> Bool -> DateSpan -> [Posting] -> [SummaryPosting] summarisePostingsByInterval interval wd depth showempty reportspan ps = concatMap summarisespan $ splitSpan interval reportspan where summarisespan s = summarisePostingsInDateSpan s wd depth showempty (postingsinspan s) postingsinspan s = filter (isPostingInDateSpan' wd s) ps tests_summarisePostingsByInterval = [ "summarisePostingsByInterval" ~: do summarisePostingsByInterval (Quarters 1) PrimaryDate 99999 False (DateSpan Nothing Nothing) [] ~?= [] ] -- | A summary posting summarises the activity in one account within a report -- interval. It is currently kludgily represented by a regular Posting with no -- description, the interval's start date stored as the posting date, and the -- interval's end date attached with a tuple. type SummaryPosting = (Posting, Maybe Day) -- | Given a date span (representing a reporting interval) and a list of -- postings within it, aggregate the postings into one summary posting per -- account. -- -- When a depth argument is present, postings to accounts of greater -- depth are also aggregated where possible. If the depth is 0, all -- postings in the span are aggregated into a single posting with -- account name "...". -- -- The showempty flag includes spans with no postings and also postings -- with 0 amount. -- summarisePostingsInDateSpan :: DateSpan -> WhichDate -> Int -> Bool -> [Posting] -> [SummaryPosting] summarisePostingsInDateSpan (DateSpan b e) wd depth showempty ps | null ps && (isNothing b || isNothing e) = [] | null ps && showempty = [(summaryp, Just e')] | otherwise = summarypes where postingdate = if wd == PrimaryDate then postingDate else postingDate2 b' = fromMaybe (maybe nulldate postingdate $ headMay ps) b e' = fromMaybe (maybe (addDays 1 nulldate) postingdate $ lastMay ps) e summaryp = nullposting{pdate=Just b'} clippedanames | depth > 0 = nub $ map (clipAccountName depth) anames | otherwise = ["..."] summaryps | depth > 0 = [summaryp{paccount=a,pamount=balance a} | a <- clippedanames] | otherwise = [summaryp{paccount="...",pamount=sum $ map pamount ps}] summarypes = map (, Just e') $ (if showempty then id else filter (not . isZeroMixedAmount . pamount)) summaryps 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 -- tests_summarisePostingsInDateSpan = [ -- "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]} -- ] 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 Cleared, Acct "expenses"], samplejournal) `gives` 2 (And [And [Depth 1, Status Cleared], 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} Any 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_Hledger_Reports_PostingsReport :: Test tests_Hledger_Reports_PostingsReport = TestList $ tests_summarisePostingsByInterval ++ tests_postingsReport hledger-lib-0.26/Hledger/Reports/ReportOptions.hs0000644000000000000000000002626412550610364020214 0ustar0000000000000000{-# LANGUAGE RecordWildCards, DeriveDataTypeable #-} {-| Options common to most hledger reports. -} module Hledger.Reports.ReportOptions ( ReportOpts(..), BalanceType(..), AccountListMode(..), FormatStr, defreportopts, rawOptsToReportOpts, flat_, tree_, dateSpanFromOpts, intervalFromOpts, clearedValueFromOpts, whichDateFromOpts, journalSelectingAmountFromOpts, queryFromOpts, queryFromOptsOnly, queryOptsFromOpts, transactionDateFn, postingDateFn, tests_Hledger_Reports_ReportOptions ) where import Data.Data (Data) import Data.Typeable (Typeable) import Data.Time.Calendar import System.Console.CmdArgs.Default -- some additional default stuff import Test.HUnit import Hledger.Data import Hledger.Query import Hledger.Utils 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 -- | Should accounts be displayed: in the command's default style, hierarchically, or as a flat list ? data AccountListMode = ALDefault | ALTree | ALFlat deriving (Eq, Show, Data, Typeable) instance Default AccountListMode where def = ALDefault -- | 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 ,pending_ :: Bool ,uncleared_ :: Bool ,cost_ :: Bool ,depth_ :: Maybe Int ,display_ :: Maybe DisplayExp ,date2_ :: Bool ,empty_ :: Bool ,no_elide_ :: Bool ,real_ :: Bool ,daily_ :: Bool ,weekly_ :: Bool ,monthly_ :: Bool ,quarterly_ :: Bool ,yearly_ :: Bool ,format_ :: Maybe FormatStr ,query_ :: String -- all arguments, as a string -- register ,average_ :: Bool ,related_ :: Bool -- balance ,balancetype_ :: BalanceType ,accountlistmode_ :: AccountListMode ,drop_ :: Int ,row_total_ :: Bool ,no_total_ :: Bool } deriving (Show, Data, Typeable) instance Default ReportOpts where def = defreportopts defreportopts :: ReportOpts 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 def def rawOptsToReportOpts :: RawOpts -> IO ReportOpts rawOptsToReportOpts rawopts = do d <- getCurrentDay return defreportopts{ begin_ = maybesmartdateopt d "begin" rawopts ,end_ = maybesmartdateopt d "end" rawopts ,period_ = maybeperiodopt d rawopts ,cleared_ = boolopt "cleared" rawopts ,pending_ = boolopt "pending" rawopts ,uncleared_ = boolopt "uncleared" rawopts ,cost_ = boolopt "cost" rawopts ,depth_ = maybeintopt "depth" rawopts ,display_ = maybedisplayopt d rawopts ,date2_ = boolopt "date2" rawopts ,empty_ = boolopt "empty" rawopts ,no_elide_ = boolopt "no-elide" rawopts ,real_ = boolopt "real" rawopts ,daily_ = boolopt "daily" rawopts ,weekly_ = boolopt "weekly" rawopts ,monthly_ = boolopt "monthly" rawopts ,quarterly_ = boolopt "quarterly" rawopts ,yearly_ = boolopt "yearly" rawopts ,format_ = maybestringopt "format" rawopts ,query_ = unwords $ listofstringopt "args" rawopts -- doesn't handle an arg like "" right ,average_ = boolopt "average" rawopts ,related_ = boolopt "related" rawopts ,balancetype_ = balancetypeopt rawopts ,accountlistmode_ = accountlistmodeopt rawopts ,drop_ = intopt "drop" rawopts ,row_total_ = boolopt "row-total" rawopts ,no_total_ = boolopt "no-total" rawopts } accountlistmodeopt :: RawOpts -> AccountListMode accountlistmodeopt rawopts = case reverse $ filter (`elem` ["tree","flat"]) $ map fst rawopts of ("tree":_) -> ALTree ("flat":_) -> ALFlat _ -> ALDefault balancetypeopt :: RawOpts -> BalanceType balancetypeopt rawopts | length [o | o <- ["cumulative","historical"], isset o] > 1 = optserror "please specify at most one of --cumulative and --historical" | isset "cumulative" = CumulativeBalance | isset "historical" = HistoricalBalance | otherwise = PeriodBalance where isset = flip boolopt rawopts maybesmartdateopt :: Day -> String -> RawOpts -> Maybe Day maybesmartdateopt d name rawopts = case maybestringopt name rawopts of Nothing -> Nothing Just s -> either (\e -> optserror $ "could not parse "++name++" date: "++show e) Just $ fixSmartDateStrEither' d s type DisplayExp = String maybedisplayopt :: Day -> RawOpts -> Maybe DisplayExp maybedisplayopt d rawopts = maybe Nothing (Just . regexReplaceBy "\\[.+?\\]" fixbracketeddatestr) $ maybestringopt "display" rawopts where fixbracketeddatestr "" = "" fixbracketeddatestr s = "[" ++ fixSmartDateStr d (init $ tail s) ++ "]" maybeperiodopt :: Day -> RawOpts -> Maybe (Interval,DateSpan) maybeperiodopt d rawopts = case maybestringopt "period" rawopts of Nothing -> Nothing Just s -> either (\e -> optserror $ "could not parse period option: "++show e) Just $ parsePeriodExpr d s -- | Legacy-compatible convenience aliases for accountlistmode_. tree_ :: ReportOpts -> Bool tree_ = (==ALTree) . accountlistmode_ flat_ :: ReportOpts -> Bool flat_ = (==ALFlat) . accountlistmode_ -- | 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 ClearedStatus clearedValueFromOpts ReportOpts{..} | cleared_ = Just Cleared | pending_ = Just Pending | uncleared_ = Just Uncleared | 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_ -- | Convert report options to a query, ignoring any non-flag command line arguments. queryFromOptsOnly :: Day -> ReportOpts -> Query queryFromOptsOnly d opts@ReportOpts{..} = simplifyQuery flagsq 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_) tests_queryFromOpts :: [Test] 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_="date2:'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 :: [Test] 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'" }) ] tests_Hledger_Reports_ReportOptions :: Test tests_Hledger_Reports_ReportOptions = TestList $ tests_queryFromOpts ++ tests_queryOptsFromOpts hledger-lib-0.26/Hledger/Reports/TransactionsReports.hs0000644000000000000000000002621712550610364021412 0ustar0000000000000000{-# LANGUAGE RecordWildCards, DeriveDataTypeable, FlexibleInstances #-} {-| Here are several variants of a transactions report. Transactions reports are like a postings report, but more transaction-oriented, and (in the account-centric variant) relative to a some base account. They are used by hledger-web. -} module Hledger.Reports.TransactionsReports ( TransactionsReport, TransactionsReportItem, triOrigTransaction, triDate, triAmount, triBalance, triCommodityAmount, triCommodityBalance, journalTransactionsReport, accountTransactionsReport, transactionsReportByCommodity -- -- * Tests -- tests_Hledger_Reports_TransactionsReports ) where import Data.List import Data.Ord -- import Test.HUnit import Hledger.Data import Hledger.Query import Hledger.Reports.ReportOptions -- | 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 original journal transaction, unmodified ,Transaction -- the transaction as seen from a particular account ,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 ) triOrigTransaction (torig,_,_,_,_,_) = torig triDate (_,tacct,_,_,_,_) = tdate tacct triAmount (_,_,_,_,a,_) = a triBalance (_,_,_,_,_,a) = a triCommodityAmount c = filterMixedAmountByCommodity c . triAmount triCommodityBalance c = filterMixedAmountByCommodity c . triBalance ------------------------------------------------------------------------------- -- | Select transactions from the whole journal. This is similar to a -- "postingsReport" except with transaction-based report items which -- are ordered most recent first. XXX Or an EntriesReport - use that instead ? -- This is used by hledger-web's journal view. journalTransactionsReport :: ReportOpts -> Journal -> Query -> TransactionsReport journalTransactionsReport opts j q = (totallabel, items) where -- XXX items' first element should be the full transaction with all postings items = reverse $ accountTransactionsReportItems q None nullmixedamt id ts ts = sortBy (comparing date) $ filter (q `matchesTransaction`) $ jtxns $ journalSelectingAmountFromOpts opts j date = transactionDateFn opts ------------------------------------------------------------------------------- -- | An account transactions report represents transactions affecting -- a particular account (or possibly several accounts, but we don't -- use that). It is used by hledger-web's account register view, where -- we want to show one row per journal transaction, with: -- -- - the total increase/decrease to the current account -- -- - the names of the other account(s) posted to/from -- -- - transaction dates adjusted to the date of the earliest posting to -- the current account, if those postings have their own dates -- -- Currently, reporting intervals are not supported, and report items -- are most recent first. -- type AccountTransactionsReport = (String -- label for the balance column, eg "balance" or "total" ,[AccountTransactionsReportItem] -- line items, one per transaction ) type AccountTransactionsReportItem = ( Transaction -- the original journal transaction ,Transaction -- the adjusted account transaction ,Bool -- is this a split, ie with more than one posting to other account(s) ,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 ) accountTransactionsReport :: ReportOpts -> Journal -> Query -> Query -> AccountTransactionsReport accountTransactionsReport opts j q thisacctquery = (label, items) where -- transactions with excluded currencies removed ts1 = jtxns $ filterJournalAmounts (filterQuery queryIsSym q) $ journalSelectingAmountFromOpts opts j -- affecting this account ts2 = filter (matchesTransaction thisacctquery) ts1 -- with dates adjusted for account transactions report ts3 = map (setTransactionDateToPostingDate q thisacctquery) ts2 -- and sorted ts = sortBy (comparing tdate) ts3 -- 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 q = (nullmixedamt, balancelabel) | queryIsStartDateOnly (date2_ opts) q = (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) q items = reverse $ -- see also registerChartHtml accountTransactionsReportItems q thisacctquery startbal negate ts -- | Adjust a transaction's date to the earliest date of postings to a -- particular account, if any, after filtering with a certain query. setTransactionDateToPostingDate :: Query -> Query -> Transaction -> Transaction setTransactionDateToPostingDate query thisacctquery t = t' where queryps = tpostings $ filterTransactionPostings query t thisacctps = filter (matchesPosting thisacctquery) queryps t' = case thisacctps of [] -> t _ -> t{tdate=d} where d | null ds = tdate t | otherwise = minimum ds ds = map postingDate thisacctps -- no opts here, don't even bother with that date/date2 rigmarole totallabel = "Running Total" balancelabel = "Historical Balance" -- | 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. With a -- "this account" query of None, this can be used the for the -- journalTransactionsReport also. accountTransactionsReportItems :: Query -> Query -> MixedAmount -> (MixedAmount -> MixedAmount) -> [Transaction] -> [TransactionsReportItem] accountTransactionsReportItems _ _ _ _ [] = [] accountTransactionsReportItems query thisacctquery bal signfn (torig: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 -- XXX I've lost my grip on this, let's just hope for the best origps = tpostings torig tacct@Transaction{tpostings=queryps} = filterTransactionPostings query torig (thisacctps, otheracctps) = partition (matchesPosting thisacctquery) origps amt = negate $ sum $ map pamount thisacctps numotheraccts = length $ nub $ map paccount otheracctps otheracctstr | thisacctquery == None = summarisePostingAccounts origps | numotheraccts == 0 = summarisePostingAccounts thisacctps | otherwise = summarisePostingAccounts otheracctps (i,bal') = case queryps of [] -> (Nothing,bal) _ -> (Just (torig, tacct, numotheraccts > 1, otheracctstr, 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} ------------------------------------------------------------------------------- -- | Split a transactions report whose items may involve several commodities, -- into one or more single-commodity transactions reports. transactionsReportByCommodity :: TransactionsReport -> [(Commodity, TransactionsReport)] transactionsReportByCommodity tr = [(c, 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 ------------------------------------------------------------------------------- hledger-lib-0.26/Hledger/Utils/0000755000000000000000000000000012550610364014461 5ustar0000000000000000hledger-lib-0.26/Hledger/Utils/Debug.hs0000644000000000000000000001774712550610364016063 0ustar0000000000000000{-# LANGUAGE CPP, FlexibleContexts #-} -- | Debugging helpers -- 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 module Hledger.Utils.Debug ( module Hledger.Utils.Debug ,module Debug.Trace #if __GLASGOW_HASKELL__ >= 704 ,ppShow #endif ) where import Control.Monad (when) import Data.List import Debug.Trace import Safe (readDef) import System.Environment (getArgs) import System.Exit import System.IO.Unsafe (unsafePerformIO) import Text.Parsec import Text.Printf #if __GLASGOW_HASKELL__ >= 704 import Text.Show.Pretty (ppShow) #else -- the required pretty-show version requires GHC >= 7.4 ppShow :: Show a => a -> String ppShow = show #endif -- | 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 :: Stream [Char] m t => String -> ParsecT [Char] st m () 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'. -- {-# OPTIONS_GHC -fno-cse #-} -- {-# NOINLINE debugLevel #-} 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 -- | Convenience aliases for tracePrettyAt. -- Pretty-print a message and the showable value to the console, then return it. dbg :: Show a => String -> a -> a dbg = tracePrettyAt 0 -- | Pretty-print a message and the showable value to the console when the debug level is >= 1, then return it. Uses unsafePerformIO. dbg1 :: Show a => String -> a -> a dbg1 = tracePrettyAt 1 dbg2 :: Show a => String -> a -> a dbg2 = tracePrettyAt 2 dbg3 :: Show a => String -> a -> a dbg3 = tracePrettyAt 3 dbg4 :: Show a => String -> a -> a dbg4 = tracePrettyAt 4 dbg5 :: Show a => String -> a -> a dbg5 = tracePrettyAt 5 dbg6 :: Show a => String -> a -> a dbg6 = tracePrettyAt 6 dbg7 :: Show a => String -> a -> a dbg7 = tracePrettyAt 7 dbg8 :: Show a => String -> a -> a dbg8 = tracePrettyAt 8 dbg9 :: Show a => String -> a -> a dbg9 = tracePrettyAt 9 -- | Convenience aliases for tracePrettyAtIO. -- Like dbg, but convenient to insert in an IO monad. dbgIO :: Show a => String -> a -> IO () dbgIO = tracePrettyAtIO 0 dbg1IO :: Show a => String -> a -> IO () dbg1IO = tracePrettyAtIO 1 dbg2IO :: Show a => String -> a -> IO () dbg2IO = tracePrettyAtIO 2 dbg3IO :: Show a => String -> a -> IO () dbg3IO = tracePrettyAtIO 3 dbg4IO :: Show a => String -> a -> IO () dbg4IO = tracePrettyAtIO 4 dbg5IO :: Show a => String -> a -> IO () dbg5IO = tracePrettyAtIO 5 dbg6IO :: Show a => String -> a -> IO () dbg6IO = tracePrettyAtIO 6 dbg7IO :: Show a => String -> a -> IO () dbg7IO = tracePrettyAtIO 7 dbg8IO :: Show a => String -> a -> IO () dbg8IO = tracePrettyAtIO 8 dbg9IO :: Show a => String -> a -> IO () dbg9IO = tracePrettyAtIO 9 -- | Pretty-print a message and a showable value to the console if the debug level is at or above the specified level. -- dbtAt 0 always prints. Otherwise, uses unsafePerformIO. tracePrettyAt :: Show a => Int -> String -> a -> a tracePrettyAt lvl = dbgppshow lvl tracePrettyAtIO :: Show a => Int -> String -> a -> IO () tracePrettyAtIO lvl lbl x = tracePrettyAt lvl lbl x `seq` return () -- XXX -- Could not deduce (a ~ ()) -- from the context (Show a) -- bound by the type signature for -- dbgM :: Show a => String -> a -> IO () -- at hledger/Hledger/Cli/Main.hs:200:13-42 -- ‘a’ is a rigid type variable bound by -- the type signature for dbgM :: Show a => String -> a -> IO () -- at hledger/Hledger/Cli/Main.hs:200:13 -- Expected type: String -> a -> IO () -- Actual type: String -> a -> IO a -- -- tracePrettyAtM :: (Monad m, Show a) => Int -> String -> a -> m a -- tracePrettyAtM lvl lbl x = tracePrettyAt lvl lbl x `seq` return x -- | print this string to the console before evaluating the expression, -- if the global debug level is non-zero. Uses unsafePerformIO. dbgtrace :: String -> a -> a dbgtrace | debugLevel > 0 = trace | 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 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 | level > 0 && debugLevel < level = flip const | otherwise = \s a -> let p = ppShow a ls = lines p nlorspace | length ls > 1 = "\n" | otherwise = " " ++ take (10 - length s) (repeat ' ') ls' | length ls > 1 = map (" "++) ls | otherwise = ls in trace (s++":"++nlorspace++intercalate "\n" ls') a -- -- | 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 :: Stream [Char] m t => Int -> String -> ParsecT [Char] st m () pdbg level msg = when (level <= debugLevel) $ ptrace msg hledger-lib-0.26/Hledger/Utils/Regex.hs0000644000000000000000000001003112550610364016062 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-| Easy regular expression helpers, currently based on regex-tdfa. These should: - be cross-platform, not requiring C libraries - support unicode - support extended regular expressions - support replacement, with backreferences etc. - support splitting - have mnemonic names - have simple monomorphic types - work with strings Current limitations: - (?i) and similar are not supported -} module Hledger.Utils.Regex ( -- * type aliases Regexp ,Replacement -- * standard regex operations ,regexMatches ,regexMatchesCI ,regexReplace ,regexReplaceCI ,regexReplaceBy ,regexReplaceByCI ) where import Data.Array import Data.Char import Data.List (foldl') import Text.Regex.TDFA ( Regex, CompOption(..), ExecOption(..), defaultCompOpt, defaultExecOpt, makeRegexOpts, AllMatches(getAllMatches), match, (=~), MatchText ) -- import Hledger.Utils.Debug import Hledger.Utils.UTF8IOCompat (error') -- | Regular expression. Extended regular expression-ish syntax ? But does not support eg (?i) syntax. type Regexp = String -- | A replacement pattern. May include numeric backreferences (\N). type Replacement = String -- | Convert our string-based regexps to real ones. Can fail if the -- string regexp is malformed. toRegex :: Regexp -> Regex toRegex = makeRegexOpts compOpt execOpt toRegexCI :: Regexp -> Regex toRegexCI = makeRegexOpts compOpt{caseSensitive=False} execOpt compOpt :: CompOption compOpt = defaultCompOpt execOpt :: ExecOption execOpt = defaultExecOpt -- regexMatch' :: RegexContext Regexp String a => Regexp -> String -> a -- regexMatch' r s = s =~ (toRegex r) regexMatches :: Regexp -> String -> Bool regexMatches = flip (=~) regexMatchesCI :: Regexp -> String -> Bool regexMatchesCI r = match (toRegexCI r) -- | Replace all occurrences of the regexp, transforming each match with the given function. regexReplaceBy :: Regexp -> (String -> String) -> String -> String regexReplaceBy r = replaceAllBy (toRegex r) regexReplaceByCI :: Regexp -> (String -> String) -> String -> String regexReplaceByCI r = replaceAllBy (toRegexCI r) -- | Replace all occurrences of the regexp with the replacement -- pattern. The replacement pattern supports numeric backreferences -- (\N) but no other RE syntax. regexReplace :: Regexp -> Replacement -> String -> String regexReplace re = replaceRegex (toRegex re) regexReplaceCI :: Regexp -> Replacement -> String -> String regexReplaceCI re = replaceRegex (toRegexCI re) -- replaceRegex :: Regex -> Replacement -> String -> String replaceRegex re repl s = foldl (replaceMatch repl) s (reverse $ match re s :: [MatchText String]) replaceMatch :: Replacement -> String -> MatchText String -> String replaceMatch replpat s matchgroups = pre ++ repl ++ post where ((_,(off,len)):_) = elems matchgroups -- groups should have 0-based indexes, and there should always be at least one, since this is a match (pre, post') = splitAt off s post = drop len post' repl = replaceAllBy (toRegex "\\\\[0-9]+") (replaceBackReference matchgroups) replpat replaceBackReference :: MatchText String -> String -> String replaceBackReference grps ('\\':s@(_:_)) | all isDigit s = case read s of n | n `elem` indices grps -> fst (grps ! n) _ -> error' $ "no match group exists for backreference \"\\"++s++"\"" replaceBackReference _ s = error' $ "replaceBackReference called on non-numeric-backreference \""++s++"\", shouldn't happen" -- -- http://stackoverflow.com/questions/9071682/replacement-substition-with-haskell-regex-libraries : -- | Replace all occurrences of a regexp in a string, transforming each match with the given function. replaceAllBy :: Regex -> (String -> String) -> String -> String replaceAllBy re f s = start end where (_, end, start) = foldl' go (0, s, id) $ (getAllMatches $ match re s :: [(Int, Int)]) go (ind,read,write) (off,len) = let (skip, start) = splitAt (off - ind) read (matched, remaining) = splitAt len start in (off + len, remaining, write . (skip++) . (f matched ++)) hledger-lib-0.26/Hledger/Utils/UTF8IOCompat.hs0000644000000000000000000000757312550610364017153 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.26/tests/0000755000000000000000000000000012550610364013151 5ustar0000000000000000hledger-lib-0.26/tests/suite.hs0000644000000000000000000000031712550610364014637 0ustar0000000000000000import Hledger (tests_Hledger) import Test.Framework.Providers.HUnit (hUnitTestToTests) import Test.Framework.Runners.Console (defaultMain) main :: IO () main = defaultMain $ hUnitTestToTests tests_Hledger