diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,674 @@ + 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 +. diff --git a/Ledger.hs b/Ledger.hs new file mode 100644 --- /dev/null +++ b/Ledger.hs @@ -0,0 +1,58 @@ +{-| + +The Ledger library allows parsing and querying of ledger files. It +generally provides a compatible subset of C++ ledger's functionality. +This package re-exports all the Ledger.* modules. + +-} + +module Ledger ( + module Ledger.Account, + module Ledger.AccountName, + module Ledger.Amount, + module Ledger.Commodity, + module Ledger.Dates, + module Ledger.IO, + module Ledger.Transaction, + module Ledger.Ledger, + module Ledger.Parse, + module Ledger.Journal, + module Ledger.Posting, + module Ledger.TimeLog, + module Ledger.Types, + module Ledger.Utils, + tests_Ledger + ) +where +import Ledger.Account +import Ledger.AccountName +import Ledger.Amount +import Ledger.Commodity +import Ledger.Dates +import Ledger.IO +import Ledger.Transaction +import Ledger.Ledger +import Ledger.Parse +import Ledger.Journal +import Ledger.Posting +import Ledger.TimeLog +import Ledger.Types +import Ledger.Utils + +tests_Ledger = TestList + [ + -- Ledger.Account.tests_Account + -- ,Ledger.AccountName.tests_AccountName + Ledger.Amount.tests_Amount + -- ,Ledger.Commodity.tests_Commodity + ,Ledger.Dates.tests_Dates + -- ,Ledger.IO.tests_IO + ,Ledger.Transaction.tests_Transaction + -- ,Ledger.Ledger.tests_Ledger + ,Ledger.Parse.tests_Parse + -- ,Ledger.Journal.tests_Journal + -- ,Ledger.Posting.tests_Posting + -- ,Ledger.TimeLog.tests_TimeLog + -- ,Ledger.Types.tests_Types + -- ,Ledger.Utils.tests_Utils + ] diff --git a/Ledger/Account.hs b/Ledger/Account.hs new file mode 100644 --- /dev/null +++ b/Ledger/Account.hs @@ -0,0 +1,27 @@ +{-| + +A compound data type for efficiency. An 'Account' stores + +- an 'AccountName', + +- all 'Posting's in the account, excluding subaccounts + +- a 'MixedAmount' representing the account balance, including subaccounts. + +-} + +module Ledger.Account +where +import Ledger.Utils +import Ledger.Types +import Ledger.Amount + + +instance Show Account where + show (Account a ts b) = printf "Account %s with %d txns and %s balance" a (length ts) (showMixedAmount b) + +instance Eq Account where + (==) (Account n1 t1 b1) (Account n2 t2 b2) = n1 == n2 && t1 == t2 && b1 == b2 + +nullacct = Account "" [] nullmixedamt + diff --git a/Ledger/AccountName.hs b/Ledger/AccountName.hs new file mode 100644 --- /dev/null +++ b/Ledger/AccountName.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE NoMonomorphismRestriction#-} +{-| + +'AccountName's are strings like @assets:cash:petty@. +From a set of these we derive the account hierarchy. + +-} + +module Ledger.AccountName +where +import Ledger.Utils +import Ledger.Types +import Data.Map (Map) +import qualified Data.Map as M + + + +-- 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 + +-- | ["a:b:c","d:e"] -> ["a","a:b","a:b:c","d","d:e"] +expandAccountNames :: [AccountName] -> [AccountName] +expandAccountNames as = nub $ concatMap expand as + where expand = map accountNameFromComponents . tail . inits . accountNameComponents + +-- | ["a:b:c","d:e"] -> ["a","d"] +topAccountNames :: [AccountName] -> [AccountName] +topAccountNames as = [a | a <- expandAccountNames as, accountNameLevel a == 1] + +parentAccountName :: AccountName -> AccountName +parentAccountName = accountNameFromComponents . init . accountNameComponents + +parentAccountNames :: AccountName -> [AccountName] +parentAccountNames a = parentAccountNames' $ parentAccountName a + where + parentAccountNames' "" = [] + parentAccountNames' a = a : parentAccountNames' (parentAccountName a) + +isAccountNamePrefixOf :: AccountName -> AccountName -> Bool +isAccountNamePrefixOf = isPrefixOf . (++ [acctsepchar]) + +isSubAccountNameOf :: AccountName -> AccountName -> Bool +s `isSubAccountNameOf` p = + (p `isAccountNamePrefixOf` s) && (accountNameLevel s == (accountNameLevel p + 1)) + +-- | From a list of account names, select those which are direct +-- subaccounts of the given account name. +subAccountNamesFrom :: [AccountName] -> AccountName -> [AccountName] +subAccountNamesFrom accts a = filter (`isSubAccountNameOf` a) accts + +-- | Convert a list of account names to a tree. +accountNameTreeFrom :: [AccountName] -> Tree AccountName +accountNameTreeFrom = accountNameTreeFrom1 + +accountNameTreeFrom1 accts = + Node "top" (accounttreesfrom (topAccountNames accts)) + where + accounttreesfrom :: [AccountName] -> [Tree AccountName] + accounttreesfrom [] = [] + accounttreesfrom as = [Node a (accounttreesfrom $ subs a) | a <- as] + subs = subAccountNamesFrom (expandAccountNames accts) + +nullaccountnametree = Node "top" [] + +accountNameTreeFrom2 accts = + Node "top" $ unfoldForest (\a -> (a, subs a)) $ topAccountNames accts + where + subs = subAccountNamesFrom allaccts + allaccts = expandAccountNames accts + -- subs' a = subsmap ! a + -- subsmap :: Map AccountName [AccountName] + -- subsmap = Data.Map.fromList [(a, subAccountNamesFrom allaccts a) | a <- allaccts] + +accountNameTreeFrom3 accts = + Node "top" $ forestfrom allaccts $ topAccountNames accts + where + -- drop accts from the list of potential subs as we add them to the tree + forestfrom :: [AccountName] -> [AccountName] -> Forest AccountName + forestfrom subaccts accts = + [let subaccts' = subaccts \\ accts in Node a $ forestfrom subaccts' (subAccountNamesFrom subaccts' a) | a <- accts] + allaccts = expandAccountNames accts + + +-- a more efficient tree builder from Cale Gibbard +newtype Tree' a = T (Map a (Tree' a)) + deriving (Show, Eq, Ord) + +mergeTrees :: (Ord a) => Tree' a -> Tree' a -> Tree' a +mergeTrees (T m) (T m') = T (M.unionWith mergeTrees m m') + +emptyTree = T M.empty + +pathtree :: [a] -> Tree' a +pathtree [] = T M.empty +pathtree (x:xs) = T (M.singleton x (pathtree xs)) + +fromPaths :: (Ord a) => [[a]] -> Tree' a +fromPaths = foldl' mergeTrees emptyTree . map pathtree + +-- the above, but trying to build Tree directly + +-- mergeTrees' :: (Ord a) => Tree a -> Tree a -> Tree a +-- mergeTrees' (Node m ms) (Node m' ms') = Node undefined (ms `union` ms') + +-- emptyTree' = Node "top" [] + +-- pathtree' :: [a] -> Tree a +-- pathtree' [] = Node undefined [] +-- pathtree' (x:xs) = Node x [pathtree' xs] + +-- fromPaths' :: (Ord a) => [[a]] -> Tree a +-- fromPaths' = foldl' mergeTrees' emptyTree' . map pathtree' + + +-- converttree :: [AccountName] -> Tree' AccountName -> [Tree AccountName] +-- converttree parents (T m) = [Node (accountNameFromComponents $ parents ++ [a]) (converttree (parents++[a]) b) | (a,b) <- M.toList m] + +-- accountNameTreeFrom4 :: [AccountName] -> Tree AccountName +-- accountNameTreeFrom4 accts = Node "top" (converttree [] $ fromPaths $ map accountNameComponents accts) + +converttree :: Tree' AccountName -> [Tree AccountName] +converttree (T m) = [Node a (converttree b) | (a,b) <- M.toList m] + +expandTreeNames :: Tree AccountName -> Tree AccountName +expandTreeNames (Node x ts) = Node x (map (treemap (\n -> accountNameFromComponents [x,n]) . expandTreeNames) ts) + +accountNameTreeFrom4 :: [AccountName] -> Tree AccountName +accountNameTreeFrom4 = Node "top" . map expandTreeNames . converttree . fromPaths . map accountNameComponents + + +-- | Elide an account name to fit in the specified width. +-- From the ledger 2.6 news: +-- +-- @ +-- What Ledger now does is that if an account name is too long, it will +-- start abbreviating the first parts of the account name down to two +-- letters in length. If this results in a string that is still too +-- long, the front will be elided -- not the end. For example: +-- +-- Expenses:Cash ; OK, not too long +-- Ex:Wednesday:Cash ; "Expenses" was abbreviated to fit +-- Ex:We:Afternoon:Cash ; "Expenses" and "Wednesday" abbreviated +-- ; Expenses:Wednesday:Afternoon:Lunch:Snack:Candy:Chocolate:Cash +-- ..:Af:Lu:Sn:Ca:Ch:Cash ; Abbreviated and elided! +-- @ +elideAccountName :: Int -> AccountName -> AccountName +elideAccountName width s = + elideLeft width $ accountNameFromComponents $ elideparts width [] $ accountNameComponents s + where + elideparts :: Int -> [String] -> [String] -> [String] + elideparts width done ss + | length (accountNameFromComponents $ done++ss) <= width = done++ss + | length ss > 1 = elideparts width (done++[take 2 $ head ss]) (tail ss) + | otherwise = done++ss + +clipAccountName :: Int -> AccountName -> AccountName +clipAccountName n = accountNameFromComponents . take n . accountNameComponents + diff --git a/Ledger/Amount.hs b/Ledger/Amount.hs new file mode 100644 --- /dev/null +++ b/Ledger/Amount.hs @@ -0,0 +1,340 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-| +An 'Amount' is some quantity of money, shares, or anything else. + +A simple amount is a 'Commodity', quantity pair: + +@ + $1 + £-50 + EUR 3.44 + GOOG 500 + 1.5h + 90 apples + 0 +@ + +An amount may also have a per-unit price, or conversion rate, in terms +of some other commodity. If present, this is displayed after \@: + +@ + EUR 3 \@ $1.35 +@ + +A 'MixedAmount' is zero or more simple amounts. Mixed amounts are +usually normalised so that there is no more than one amount in each +commodity, and no zero amounts (or, there is just a single zero amount +and no others.): + +@ + $50 + EUR 3 + 16h + $13.55 + AAPL 500 + 6 oranges + 0 +@ + +We can do limited arithmetic with simple or mixed amounts: either +price-preserving arithmetic with similarly-priced amounts, or +price-discarding arithmetic which ignores and discards prices. + +-} + +module Ledger.Amount +where +import Ledger.Utils +import Ledger.Types +import Ledger.Commodity + + +instance Show Amount where show = showAmount +instance Show MixedAmount where show = showMixedAmount +deriving instance Show HistoricalPrice + +instance Num Amount where + abs (Amount c q p) = Amount c (abs q) p + signum (Amount c q p) = Amount c (signum q) p + fromInteger i = Amount (comm "") (fromInteger i) Nothing + (+) = amountop (+) + (-) = amountop (-) + (*) = amountop (*) + +instance Ord Amount where + compare (Amount ac aq ap) (Amount bc bq bp) = compare (ac,aq,ap) (bc,bq,bp) + +instance Num MixedAmount where + fromInteger i = Mixed [Amount (comm "") (fromInteger i) Nothing] + negate (Mixed as) = Mixed $ map negateAmountPreservingPrice as + (+) (Mixed as) (Mixed bs) = normaliseMixedAmount $ Mixed $ as ++ bs + (*) = error "programming error, mixed amounts do not support multiplication" + abs = error "programming error, mixed amounts do not support abs" + signum = error "programming error, mixed amounts do not support signum" + +instance Ord MixedAmount where + compare (Mixed as) (Mixed bs) = compare as bs + +negateAmountPreservingPrice a = (-a){price=price a} + +-- | Apply a binary arithmetic operator to two amounts, converting to the +-- second one's commodity (and display precision), discarding any price +-- information. (Using the second commodity is best since sum and other +-- folds start with a no-commodity amount.) +amountop :: (Double -> Double -> Double) -> Amount -> Amount -> Amount +amountop op a@(Amount _ _ _) (Amount bc bq _) = + Amount bc (quantity (convertAmountTo bc a) `op` bq) Nothing + +-- | Convert an amount to the specified commodity using the appropriate +-- exchange rate (which is currently always 1). +convertAmountTo :: Commodity -> Amount -> Amount +convertAmountTo c2 (Amount c1 q _) = Amount c2 (q * conversionRate c1 c2) Nothing + +-- | Convert mixed amount to the specified commodity +convertMixedAmountTo :: Commodity -> MixedAmount -> Amount +convertMixedAmountTo c2 (Mixed ams) = Amount c2 total Nothing + where + total = sum . map (quantity . convertAmountTo c2) $ ams + +-- | Convert an amount to the commodity of its saved price, if any. +costOfAmount :: Amount -> Amount +costOfAmount a@(Amount _ _ Nothing) = a +costOfAmount (Amount _ q (Just price)) + | isZeroMixedAmount price = nullamt + | otherwise = Amount pc (pq*q) Nothing + where (Amount pc pq _) = head $ amounts price + +-- | Get the string representation of an amount, based on its commodity's +-- display settings. +showAmount :: Amount -> String +showAmount (Amount (Commodity {symbol="AUTO"}) _ _) = "" -- can appear in an error message +showAmount a@(Amount (Commodity {symbol=sym,side=side,spaced=spaced}) _ pri) = + case side of + L -> printf "%s%s%s%s" sym space quantity price + R -> printf "%s%s%s%s" quantity space sym price + where + space = if spaced then " " else "" + quantity = showAmount' a + price = case pri of (Just pamt) -> " @ " ++ showMixedAmount pamt + Nothing -> "" + +-- XXX refactor +-- | Get the unambiguous string representation of an amount, for debugging. +showAmountDebug :: Amount -> String +showAmountDebug (Amount c q pri) = printf "Amount {commodity = %s, quantity = %s, price = %s}" + (show c) (show q) (maybe "" showMixedAmountDebug pri) + +-- | Get the string representation of an amount, without any \@ price. +showAmountWithoutPrice :: Amount -> String +showAmountWithoutPrice a = showAmount a{price=Nothing} + +-- | Get the string representation (of the number part of) of an amount +showAmount' :: Amount -> String +showAmount' (Amount (Commodity {comma=comma,precision=p}) q _) = quantity + where + quantity = commad $ printf ("%."++show p++"f") q + commad = if comma then punctuatethousands else id + +-- | Add thousands-separating commas to a decimal number string +punctuatethousands :: String -> String +punctuatethousands s = + sign ++ addcommas int ++ frac + where + (sign,num) = break isDigit s + (int,frac) = break (=='.') num + addcommas = reverse . concat . intersperse "," . triples . reverse + triples [] = [] + triples l = take 3 l : triples (drop 3 l) + +-- | Does this amount appear to be zero when displayed with its given precision ? +isZeroAmount :: Amount -> Bool +isZeroAmount = null . filter (`elem` "123456789") . showAmountWithoutPrice + +-- | 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 = null . filter (`elem` "123456789") . printf "%.10f" . quantity + +-- | Access a mixed amount's components. +amounts :: MixedAmount -> [Amount] +amounts (Mixed as) = as + +-- | Does this mixed amount appear to be zero - empty, or +-- containing only simple amounts which appear to be zero ? +isZeroMixedAmount :: MixedAmount -> Bool +isZeroMixedAmount = all isZeroAmount . amounts . normaliseMixedAmount + +-- | Is this mixed amount "really" zero ? See isReallyZeroAmount. +isReallyZeroMixedAmount :: MixedAmount -> Bool +isReallyZeroMixedAmount = all isReallyZeroAmount . amounts . normaliseMixedAmount + +-- | Is this mixed amount "really" zero, after converting to cost +-- commodities where possible ? +isReallyZeroMixedAmountCost :: MixedAmount -> Bool +isReallyZeroMixedAmountCost = isReallyZeroMixedAmount . costOfMixedAmount + +-- | MixedAmount derives Eq in Types.hs, but that doesn't know that we +-- want $0 = EUR0 = 0. Yet we don't want to drag all this code in there. +-- When zero equality is important, use this, for now; should be used +-- everywhere. +mixedAmountEquals :: MixedAmount -> MixedAmount -> Bool +mixedAmountEquals a b = amounts a' == amounts b' || (isZeroMixedAmount a' && isZeroMixedAmount b') + where a' = normaliseMixedAmount a + b' = normaliseMixedAmount b + +-- | Get the string representation of a mixed amount, showing each of +-- its component amounts. NB a mixed amount can have an empty amounts +-- list in which case it shows as \"\". +showMixedAmount :: MixedAmount -> String +showMixedAmount m = vConcatRightAligned $ map show $ amounts $ normaliseMixedAmount m + +-- | Get an unambiguous string representation of a mixed amount for debugging. +showMixedAmountDebug :: MixedAmount -> String +showMixedAmountDebug m = printf "Mixed [%s]" as + where as = intercalate "\n " $ map showAmountDebug $ amounts $ normaliseMixedAmount 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) = normaliseMixedAmountIgnoringPrice m + width = maximum $ map (length . show) as + showfixedwidth = printf (printf "%%%ds" width) . showAmountWithoutPrice + +-- | Get the string representation of a mixed amount, and if it +-- appears to be all zero just show a bare 0, ledger-style. +showMixedAmountOrZero :: MixedAmount -> String +showMixedAmountOrZero a | a == missingamt = "" + | isZeroMixedAmount a = "0" + | otherwise = showMixedAmount a + +-- | Get the string representation of a mixed amount, or a bare 0, +-- without any \@ prices. +showMixedAmountOrZeroWithoutPrice :: MixedAmount -> String +showMixedAmountOrZeroWithoutPrice a + | isZeroMixedAmount a = "0" + | otherwise = showMixedAmountWithoutPrice a + +-- | Simplify a mixed amount by combining any component amounts which have +-- the same commodity and the same price. Also removes zero amounts, +-- or adds a single zero amount if there are no amounts at all. +normaliseMixedAmount :: MixedAmount -> MixedAmount +normaliseMixedAmount (Mixed as) = Mixed as'' + where + as'' = map sumSamePricedAmountsPreservingPrice $ group $ sort as' + sort = sortBy cmpsymbolandprice + cmpsymbolandprice a1 a2 = compare (sym a1,price a1) (sym a2,price a2) + group = groupBy samesymbolandprice + samesymbolandprice a1 a2 = (sym a1 == sym a2) && (price a1 == price a2) + sym = symbol . commodity + as' | null nonzeros = [head $ zeros ++ [nullamt]] + | otherwise = nonzeros + (zeros,nonzeros) = partition isReallyZeroAmount as + +-- various sum variants.. + +sumAmountsDiscardingPrice [] = nullamt +sumAmountsDiscardingPrice as = (sum as){price=Nothing} + +sumSamePricedAmountsPreservingPrice [] = nullamt +sumSamePricedAmountsPreservingPrice as = (sum as){price=price $ head as} + +-- | Simplify a mixed amount by combining any component amounts which have +-- the same commodity, ignoring and discarding their unit prices if any. +-- Also removes zero amounts, or adds a single zero amount if there are no +-- amounts at all. +normaliseMixedAmountIgnoringPrice :: MixedAmount -> MixedAmount +normaliseMixedAmountIgnoringPrice (Mixed as) = Mixed as'' + where + as'' = map sumAmountsDiscardingPrice $ group $ sort as' + group = groupBy samesymbol where samesymbol a1 a2 = sym a1 == sym a2 + sort = sortBy (comparing sym) + sym = symbol . commodity + as' | null nonzeros = [head $ zeros ++ [nullamt]] + | otherwise = nonzeros + where (zeros,nonzeros) = partition isZeroAmount as + +sumMixedAmountsPreservingHighestPrecision :: [MixedAmount] -> MixedAmount +sumMixedAmountsPreservingHighestPrecision ms = foldl' (+~) 0 ms + where (+~) (Mixed as) (Mixed bs) = normaliseMixedAmountPreservingHighestPrecision $ Mixed $ as ++ bs + +normaliseMixedAmountPreservingHighestPrecision :: MixedAmount -> MixedAmount +normaliseMixedAmountPreservingHighestPrecision (Mixed as) = Mixed as'' + where + as'' = map sumSamePricedAmountsPreservingPriceAndHighestPrecision $ group $ sort as' + sort = sortBy cmpsymbolandprice + cmpsymbolandprice a1 a2 = compare (sym a1,price a1) (sym a2,price a2) + group = groupBy samesymbolandprice + samesymbolandprice a1 a2 = (sym a1 == sym a2) && (price a1 == price a2) + sym = symbol . commodity + as' | null nonzeros = [head $ zeros ++ [nullamt]] + | otherwise = nonzeros + (zeros,nonzeros) = partition isReallyZeroAmount as + +sumSamePricedAmountsPreservingPriceAndHighestPrecision [] = nullamt +sumSamePricedAmountsPreservingPriceAndHighestPrecision as = (sumAmountsPreservingHighestPrecision as){price=price $ head as} + +sumAmountsPreservingHighestPrecision :: [Amount] -> Amount +sumAmountsPreservingHighestPrecision as = foldl' (+~) 0 as + where (+~) = amountopPreservingHighestPrecision (+) + +amountopPreservingHighestPrecision :: (Double -> Double -> Double) -> Amount -> Amount -> Amount +amountopPreservingHighestPrecision op a@(Amount ac@Commodity{precision=ap} _ _) (Amount bc@Commodity{precision=bp} bq _) = + Amount c q Nothing + where + q = quantity (convertAmountTo bc a) `op` bq + c = if ap > bp then ac else bc +-- + +-- | Convert a mixed amount's component amounts to the commodity of their +-- saved price, if any. +costOfMixedAmount :: MixedAmount -> MixedAmount +costOfMixedAmount (Mixed as) = Mixed $ map costOfAmount as + +-- | The empty simple amount. +nullamt :: Amount +nullamt = Amount unknown 0 Nothing + +-- | The empty mixed amount. +nullmixedamt :: MixedAmount +nullmixedamt = Mixed [] + +-- | A temporary value for parsed transactions which had no amount specified. +missingamt :: MixedAmount +missingamt = Mixed [Amount Commodity {symbol="AUTO",side=L,spaced=False,comma=False,precision=0} 0 Nothing] + + +tests_Amount = TestList [ + + "showMixedAmount" ~: do + showMixedAmount (Mixed [Amount dollar 0 Nothing]) `is` "$0.00" + showMixedAmount (Mixed []) `is` "0" + showMixedAmount missingamt `is` "" + + ,"showMixedAmountOrZero" ~: do + showMixedAmountOrZero (Mixed [Amount dollar 0 Nothing]) `is` "0" + showMixedAmountOrZero (Mixed []) `is` "0" + showMixedAmountOrZero missingamt `is` "" + + ,"amount arithmetic" ~: do + let a1 = dollars 1.23 + let a2 = Amount (comm "$") (-1.23) Nothing + let a3 = Amount (comm "$") (-1.23) Nothing + (a1 + a2) `is` Amount (comm "$") 0 Nothing + (a1 + a3) `is` Amount (comm "$") 0 Nothing + (a2 + a3) `is` Amount (comm "$") (-2.46) Nothing + (a3 + a3) `is` Amount (comm "$") (-2.46) Nothing + sum [a2,a3] `is` Amount (comm "$") (-2.46) Nothing + sum [a3,a3] `is` Amount (comm "$") (-2.46) Nothing + sum [a1,a2,a3,-a3] `is` Amount (comm "$") 0 Nothing + let dollar0 = dollar{precision=0} + (sum [Amount dollar 1.25 Nothing, Amount dollar0 (-1) Nothing, Amount dollar (-0.25) Nothing]) + `is` (Amount dollar 0 Nothing) + + ,"mixed amount arithmetic" ~: do + let dollar0 = dollar{precision=0} + (sum $ map (Mixed . (\a -> [a])) + [Amount dollar 1.25 Nothing, + Amount dollar0 (-1) Nothing, + Amount dollar (-0.25) Nothing]) + `is` Mixed [Amount dollar 0 Nothing] + + + ] diff --git a/Ledger/Commodity.hs b/Ledger/Commodity.hs new file mode 100644 --- /dev/null +++ b/Ledger/Commodity.hs @@ -0,0 +1,39 @@ +{-| + +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 Ledger.Commodity +where +import Ledger.Utils +import Ledger.Types + + +-- convenient amount and commodity constructors, for tests etc. + +unknown = Commodity {symbol="", side=L,spaced=False,comma=False,precision=0} +dollar = Commodity {symbol="$", side=L,spaced=False,comma=False,precision=2} +euro = Commodity {symbol="EUR",side=L,spaced=False,comma=False,precision=2} +pound = Commodity {symbol="£", side=L,spaced=False,comma=False,precision=2} +hour = Commodity {symbol="h", side=R,spaced=False,comma=False,precision=1} + +dollars n = Amount dollar n Nothing +euros n = Amount euro n Nothing +pounds n = Amount pound n Nothing +hours n = Amount hour n Nothing + +defaultcommodities = [dollar, euro, pound, hour, unknown] + +-- | Look up one of the hard-coded default commodities. For use in tests. +comm :: String -> Commodity +comm sym = fromMaybe + (error "commodity lookup failed") + $ find (\(Commodity{symbol=s}) -> s==sym) defaultcommodities + +-- | Find the conversion rate between two commodities. Currently returns 1. +conversionRate :: Commodity -> Commodity -> Double +conversionRate _ _ = 1 + diff --git a/Ledger/Dates.hs b/Ledger/Dates.hs new file mode 100644 --- /dev/null +++ b/Ledger/Dates.hs @@ -0,0 +1,464 @@ +{-| + +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. + +-} + +module Ledger.Dates +where + +import Data.Time.Format +import Data.Time.Calendar.OrdinalDate +import System.Locale (defaultTimeLocale) +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Char +import Text.ParserCombinators.Parsec.Combinator +import Ledger.Types +import Ledger.Utils + + +showDate :: Day -> String +showDate = formatTime defaultTimeLocale "%C%y/%m/%d" + +getCurrentDay :: IO Day +getCurrentDay = do + t <- getZonedTime + return $ localDay (zonedTimeToLocalTime t) + +elapsedSeconds :: Fractional a => UTCTime -> UTCTime -> a +elapsedSeconds t1 = realToFrac . diffUTCTime t1 + +-- | Split a DateSpan into one or more consecutive spans at the specified interval. +splitSpan :: Interval -> DateSpan -> [DateSpan] +splitSpan _ (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing] +splitSpan NoInterval s = [s] +splitSpan Daily s = splitspan startofday nextday s +splitSpan Weekly s = splitspan startofweek nextweek s +splitSpan Monthly s = splitspan startofmonth nextmonth s +splitSpan Quarterly s = splitspan startofquarter nextquarter s +splitSpan Yearly s = splitspan startofyear nextyear s + +splitspan :: (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan] +splitspan _ _ (DateSpan Nothing Nothing) = [] +splitspan start next (DateSpan Nothing (Just e)) = [DateSpan (Just $ start e) (Just $ next $ start e)] +splitspan start next (DateSpan (Just b) Nothing) = [DateSpan (Just $ start b) (Just $ next $ start b)] +splitspan start next span@(DateSpan (Just b) (Just e)) + | b == e = [span] + | otherwise = splitspan' start next span + where + splitspan' start next (DateSpan (Just b) (Just e)) + | b >= e = [] + | otherwise = DateSpan (Just s) (Just n) + : splitspan' start next (DateSpan (Just n) (Just e)) + where s = start b + n = next s + 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 + +-- | Parse a period expression to an Interval and overall DateSpan using +-- the provided reference date, or raise an error. +parsePeriodExpr :: Day -> String -> (Interval, DateSpan) +parsePeriodExpr refdate expr = (interval,span) + where (interval,span) = fromparse $ parsewith (periodexpr refdate) expr + +-- | 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 t s = either parseerror id $ fixSmartDateStrEither t s + +-- | A safe version of fixSmartDateStr. +fixSmartDateStrEither :: Day -> String -> Either ParseError String +fixSmartDateStrEither t s = case parsewith smartdateonly (lowercase s) of + Right sd -> Right $ showDay $ fixSmartDate t 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 + +---------------------------------------------------------------------- +-- parsing + +firstJust ms = case dropWhile (==Nothing) ms of + [] -> Nothing + (md:_) -> md + +-- | Parse a couple of date-time string formats to a time type. +parsedatetimeM :: String -> Maybe LocalTime +parsedatetimeM s = firstJust [ + parseTime defaultTimeLocale "%Y/%m/%d %H:%M:%S" s, + parseTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" s + ] + +-- | Parse a couple of date string formats to a time type. +parsedateM :: String -> Maybe Day +parsedateM s = firstJust [ + parseTime defaultTimeLocale "%Y/%m/%d" s, + parseTime defaultTimeLocale "%Y-%m-%d" s + ] + +-- | Parse a date-time string to a time type, or raise an error. +parsedatetime :: String -> LocalTime +parsedatetime s = fromMaybe (error $ "could not parse timestamp \"" ++ s ++ "\"") + (parsedatetimeM s) + +-- | Parse a date string to a time type, or raise an error. +parsedate :: String -> Day +parsedate s = fromMaybe (error $ "could not parse date \"" ++ s ++ "\"") + (parsedateM s) + +-- | Parse a time string to a time type using the provided pattern, or +-- return the default. +parsetimewith :: ParseTime t => String -> String -> t -> t +parsetimewith pat s def = fromMaybe def $ parseTime defaultTimeLocale pat s + +{-| +Parse a date in any of the formats allowed in ledger's period expressions, +and maybe some others: + +> 2004 +> 2004/10 +> 2004/10/1 +> 10/1 +> 21 +> october, oct +> yesterday, today, tomorrow +> (not yet) this/next/last week/day/month/quarter/year + +Returns a SmartDate, to be converted to a full date later (see fixSmartDate). +Assumes any text in the parse stream has been lowercased. +-} +smartdate :: GenParser Char st SmartDate +smartdate = do + let dateparsers = [yyyymmdd, ymd, ym, md, y, d, month, mon, today, yesterday, tomorrow, + lastthisnextthing + ] + (y,m,d) <- choice $ map try dateparsers + return (y,m,d) + +-- | Like smartdate, but there must be nothing other than whitespace after the date. +smartdateonly :: GenParser Char st SmartDate +smartdateonly = do + d <- smartdate + many spacenonewline + eof + return d + +datesepchar = oneOf "/-." + +yyyymmdd :: GenParser Char st SmartDate +yyyymmdd = do + y <- count 4 digit + m <- count 2 digit + guard (read m <= 12) + d <- count 2 digit + guard (read d <= 31) + return (y,m,d) + +ymd :: GenParser Char st SmartDate +ymd = do + y <- many1 digit + datesepchar + m <- try (count 2 digit) <|> count 1 digit + when (read m < 1 || (read m > 12)) $ error $ "bad month number: " ++ m + datesepchar + d <- try (count 2 digit) <|> count 1 digit + when (read d < 1 || (read d > 31)) $ error $ "bad day number: " ++ d + return $ (y,m,d) + +ym :: GenParser Char st SmartDate +ym = do + y <- many1 digit + guard (read y > 12) + datesepchar + m <- try (count 2 digit) <|> count 1 digit + guard (read m >= 1 && (read m <= 12)) + return (y,m,"") + +y :: GenParser Char st SmartDate +y = do + y <- many1 digit + guard (read y >= 1000) + return (y,"","") + +d :: GenParser Char st SmartDate +d = do + d <- many1 digit + guard (read d <= 31) + return ("","",d) + +md :: GenParser Char st SmartDate +md = do + m <- try (count 2 digit) <|> count 1 digit + guard (read m >= 1 && (read m <= 12)) + datesepchar + d <- try (count 2 digit) <|> count 1 digit + when (read d < 1 || (read d > 31)) $ fail "bad day number specified" + return ("",m,d) + +months = ["january","february","march","april","may","june", + "july","august","september","october","november","december"] +monthabbrevs = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","nov","dec"] +weekdays = ["monday","tuesday","wednesday","thursday","friday","saturday","sunday"] +weekdayabbrevs = ["mon","tue","wed","thu","fri","sat","sun"] + +monthIndex s = maybe 0 (+1) $ lowercase s `elemIndex` months +monIndex s = maybe 0 (+1) $ lowercase s `elemIndex` monthabbrevs + +month :: GenParser Char st SmartDate +month = do + m <- choice $ map (try . string) months + let i = monthIndex m + return ("",show i,"") + +mon :: GenParser Char st SmartDate +mon = do + m <- choice $ map (try . string) monthabbrevs + let i = monIndex m + return ("",show i,"") + +today,yesterday,tomorrow :: GenParser Char st SmartDate +today = string "today" >> return ("","","today") +yesterday = string "yesterday" >> return ("","","yesterday") +tomorrow = string "tomorrow" >> return ("","","tomorrow") + +lastthisnextthing :: GenParser Char st SmartDate +lastthisnextthing = do + r <- choice [ + string "last" + ,string "this" + ,string "next" + ] + many spacenonewline -- make the space optional for easier scripting + p <- choice [ + string "day" + ,string "week" + ,string "month" + ,string "quarter" + ,string "year" + ] +-- XXX support these in fixSmartDate +-- ++ (map string $ months ++ monthabbrevs ++ weekdays ++ weekdayabbrevs) + + return ("",r,p) + +periodexpr :: Day -> GenParser Char st (Interval, DateSpan) +periodexpr rdate = choice $ map try [ + intervalanddateperiodexpr rdate, + intervalperiodexpr, + dateperiodexpr rdate, + (return (NoInterval,DateSpan Nothing Nothing)) + ] + +intervalanddateperiodexpr :: Day -> GenParser Char st (Interval, DateSpan) +intervalanddateperiodexpr rdate = do + many spacenonewline + i <- periodexprinterval + many spacenonewline + s <- periodexprdatespan rdate + return (i,s) + +intervalperiodexpr :: GenParser Char st (Interval, DateSpan) +intervalperiodexpr = do + many spacenonewline + i <- periodexprinterval + return (i, DateSpan Nothing Nothing) + +dateperiodexpr :: Day -> GenParser Char st (Interval, DateSpan) +dateperiodexpr rdate = do + many spacenonewline + s <- periodexprdatespan rdate + return (NoInterval, s) + +periodexprinterval :: GenParser Char st Interval +periodexprinterval = + choice $ map try [ + tryinterval "day" "daily" Daily, + tryinterval "week" "weekly" Weekly, + tryinterval "month" "monthly" Monthly, + tryinterval "quarter" "quarterly" Quarterly, + tryinterval "year" "yearly" Yearly + ] + where + tryinterval s1 s2 v = + choice [try (string $ "every "++s1), try (string s2)] >> return v + +periodexprdatespan :: Day -> GenParser Char st DateSpan +periodexprdatespan rdate = choice $ map try [ + doubledatespan rdate, + fromdatespan rdate, + todatespan rdate, + justdatespan rdate + ] + +doubledatespan :: Day -> GenParser Char st DateSpan +doubledatespan rdate = do + optional (string "from" >> many spacenonewline) + b <- smartdate + many spacenonewline + optional (string "to" >> many spacenonewline) + e <- smartdate + return $ DateSpan (Just $ fixSmartDate rdate b) (Just $ fixSmartDate rdate e) + +fromdatespan :: Day -> GenParser Char st DateSpan +fromdatespan rdate = do + string "from" >> many spacenonewline + b <- smartdate + return $ DateSpan (Just $ fixSmartDate rdate b) Nothing + +todatespan :: Day -> GenParser Char st DateSpan +todatespan rdate = do + string "to" >> many spacenonewline + e <- smartdate + return $ DateSpan Nothing (Just $ fixSmartDate rdate e) + +justdatespan :: Day -> GenParser Char st DateSpan +justdatespan rdate = do + optional (string "in" >> many spacenonewline) + d <- smartdate + return $ spanFromSmartDate rdate d + +mkdatespan :: String -> String -> DateSpan +mkdatespan b = DateSpan (Just $ parsedate b) . Just . parsedate + +nulldatespan = DateSpan Nothing Nothing + +nulldate = parsedate "1900/01/01" + +tests_Dates = TestList [ + + "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"] + (Quarterly,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" + ] + (Quarterly,nulldatespan) `gives` + [nulldatespan] + (Daily,mkdatespan "2008/01/01" "2008/01/01") `gives` + [mkdatespan "2008/01/01" "2008/01/01"] + (Quarterly,mkdatespan "2008/01/01" "2008/01/01") `gives` + [mkdatespan "2008/01/01" "2008/01/01"] + + ] diff --git a/Ledger/IO.hs b/Ledger/IO.hs new file mode 100644 --- /dev/null +++ b/Ledger/IO.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE CPP #-} +{-| +Utilities for doing I/O with ledger files. +-} + +module Ledger.IO +where +import Control.Monad.Error +import Ledger.Ledger (cacheLedger', nullledger) +import Ledger.Parse (parseLedger) +import Ledger.Types (FilterSpec(..),WhichDate(..),Journal(..),Ledger(..)) +import Ledger.Utils (getCurrentLocalTime) +import Ledger.Dates (nulldatespan) +import System.Directory (getHomeDirectory) +import System.Environment (getEnv) +#if __GLASGOW_HASKELL__ <= 610 +import Prelude hiding (readFile) +import System.IO.UTF8 +#endif +import System.FilePath (()) +import System.Time (getClockTime) + + +ledgerenvvar = "LEDGER" +timelogenvvar = "TIMELOG" +ledgerdefaultfilename = ".ledger" +timelogdefaultfilename = ".timelog" + +nullfilterspec = FilterSpec { + datespan=nulldatespan + ,cleared=Nothing + ,real=False + ,empty=False + ,costbasis=False + ,acctpats=[] + ,descpats=[] + ,whichdate=ActualDate + ,depth=Nothing + } + +-- | Get the user's default ledger file path. +myLedgerPath :: IO String +myLedgerPath = + getEnv ledgerenvvar `catch` + (\_ -> do + home <- getHomeDirectory `catch` (\_ -> return "") + return $ home ledgerdefaultfilename) + +-- | Get the user's default timelog file path. +myTimelogPath :: IO String +myTimelogPath = + getEnv timelogenvvar `catch` + (\_ -> do + home <- getHomeDirectory + return $ home timelogdefaultfilename) + +-- | Read the user's default ledger file, or give an error. +myLedger :: IO Ledger +myLedger = myLedgerPath >>= readLedger + +-- | Read the user's default timelog file, or give an error. +myTimelog :: IO Ledger +myTimelog = myTimelogPath >>= readLedger + +-- | Read a ledger from this file, with no filtering, or give an error. +readLedger :: FilePath -> IO Ledger +readLedger f = do + t <- getClockTime + s <- readFile f + j <- journalFromString s + return $ cacheLedger' $ nullledger{journal=j{filepath=f,filereadtime=t,jtext=s}} + +-- -- | Read a ledger from this file, filtering according to the filter spec., +-- -- | or give an error. +-- readLedgerWithFilterSpec :: FilterSpec -> FilePath -> IO Ledger +-- readLedgerWithFilterSpec fspec f = do +-- s <- readFile f +-- t <- getClockTime +-- rl <- journalFromString s +-- return $ filterAndCacheLedger fspec s rl{filepath=f, filereadtime=t} + +-- | Read a Journal from the given string, using the current time as +-- reference time, or give a parse error. +journalFromString :: String -> IO Journal +journalFromString s = do + t <- getCurrentLocalTime + liftM (either error id) $ runErrorT $ parseLedger t "(string)" s + +-- -- | Expand ~ in a file path (does not handle ~name). +-- tildeExpand :: FilePath -> IO FilePath +-- tildeExpand ('~':[]) = getHomeDirectory +-- tildeExpand ('~':'/':xs) = getHomeDirectory >>= return . (++ ('/':xs)) +-- --handle ~name, requires -fvia-C or ghc 6.8: +-- --import System.Posix.User +-- -- tildeExpand ('~':xs) = do let (user, path) = span (/= '/') xs +-- -- pw <- getUserEntryForName user +-- -- return (homeDirectory pw ++ path) +-- tildeExpand xs = return xs + diff --git a/Ledger/Journal.hs b/Ledger/Journal.hs new file mode 100644 --- /dev/null +++ b/Ledger/Journal.hs @@ -0,0 +1,321 @@ +{-| + +A 'Journal' is a parsed ledger file, containing 'Transaction's. +It can be filtered and massaged in various ways, then \"crunched\" +to form a 'Ledger'. + +-} + +module Ledger.Journal +where +import qualified Data.Map as Map +import Data.Map (findWithDefault, (!)) +import System.Time (ClockTime(TOD)) +import Ledger.Utils +import Ledger.Types +import Ledger.AccountName +import Ledger.Amount +import Ledger.Transaction (ledgerTransactionWithDate) +import Ledger.Posting +import Ledger.TimeLog + + +instance Show Journal where + show j = printf "Journal with %d transactions, %d accounts: %s" + (length (jtxns j) + + length (jmodifiertxns j) + + length (jperiodictxns j)) + (length accounts) + (show accounts) + -- ++ (show $ journalTransactions l) + where accounts = flatten $ journalAccountNameTree j + +nulljournal :: Journal +nulljournal = Journal { jmodifiertxns = [] + , jperiodictxns = [] + , jtxns = [] + , open_timelog_entries = [] + , historical_prices = [] + , final_comment_lines = [] + , filepath = "" + , filereadtime = TOD 0 0 + , jtext = "" + } + +addTransaction :: Transaction -> Journal -> Journal +addTransaction t l0 = l0 { jtxns = t : jtxns l0 } + +addModifierTransaction :: ModifierTransaction -> Journal -> Journal +addModifierTransaction mt l0 = l0 { jmodifiertxns = mt : jmodifiertxns l0 } + +addPeriodicTransaction :: PeriodicTransaction -> Journal -> Journal +addPeriodicTransaction pt l0 = l0 { jperiodictxns = pt : jperiodictxns l0 } + +addHistoricalPrice :: HistoricalPrice -> Journal -> Journal +addHistoricalPrice h l0 = l0 { historical_prices = h : historical_prices l0 } + +addTimeLogEntry :: TimeLogEntry -> Journal -> Journal +addTimeLogEntry tle l0 = l0 { open_timelog_entries = tle : open_timelog_entries l0 } + +journalPostings :: Journal -> [Posting] +journalPostings = concatMap tpostings . jtxns + +journalAccountNamesUsed :: Journal -> [AccountName] +journalAccountNamesUsed = accountNamesFromPostings . journalPostings + +journalAccountNames :: Journal -> [AccountName] +journalAccountNames = sort . expandAccountNames . journalAccountNamesUsed + +journalAccountNameTree :: Journal -> Tree AccountName +journalAccountNameTree = accountNameTreeFrom . journalAccountNames + +-- Various kinds of filtering on journals. We do it differently depending +-- on the command. + +-- | Keep only transactions we are interested in, as described by +-- the filter specification. May also massage the data a little. +filterJournalTransactions :: FilterSpec -> Journal -> Journal +filterJournalTransactions FilterSpec{datespan=datespan + ,cleared=cleared + -- ,real=real + -- ,empty=empty + -- ,costbasis=_ + ,acctpats=apats + ,descpats=dpats + ,whichdate=whichdate + ,depth=depth + } = + filterJournalTransactionsByClearedStatus cleared . + filterJournalPostingsByDepth depth . + filterJournalTransactionsByAccount apats . + filterJournalTransactionsByDescription dpats . + filterJournalTransactionsByDate datespan . + journalSelectingDate whichdate + +-- | Keep only postings we are interested in, as described by +-- the filter specification. May also massage the data a little. +-- This can leave unbalanced transactions. +filterJournalPostings :: FilterSpec -> Journal -> Journal +filterJournalPostings FilterSpec{datespan=datespan + ,cleared=cleared + ,real=real + ,empty=empty +-- ,costbasis=costbasis + ,acctpats=apats + ,descpats=dpats + ,whichdate=whichdate + ,depth=depth + } = + filterJournalPostingsByRealness real . + filterJournalPostingsByClearedStatus cleared . + filterJournalPostingsByEmpty empty . + filterJournalPostingsByDepth depth . + filterJournalPostingsByAccount apats . + filterJournalTransactionsByDescription dpats . + filterJournalTransactionsByDate datespan . + journalSelectingDate whichdate + +-- | Keep only ledger 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 ledger 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 ledger 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 l = l +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 l = l +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 ledger 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 transactions which affect accounts matched by the account patterns. +filterJournalTransactionsByAccount :: [String] -> Journal -> Journal +filterJournalTransactionsByAccount apats j@Journal{jtxns=ts} = j{jtxns=filter match ts} + where match = any (matchpats apats . paccount) . tpostings + +-- | 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} + +-- | Convert this journal's transactions' primary date to either the +-- actual or effective date. +journalSelectingDate :: WhichDate -> Journal -> Journal +journalSelectingDate ActualDate j = j +journalSelectingDate EffectiveDate j = + j{jtxns=map (ledgerTransactionWithDate EffectiveDate) $ jtxns j} + +-- | Convert all the journal's amounts to their canonical display settings. +-- Ie, in each commodity, amounts will use the display settings of the first +-- amount detected, and the greatest precision of the amounts detected. +-- Also, missing unit prices are added if known from the price history. +-- Also, amounts are converted to cost basis if that flag is active. +-- XXX refactor +canonicaliseAmounts :: Bool -> Journal -> Journal +canonicaliseAmounts costbasis j@Journal{jtxns=ts} = j{jtxns=map fixledgertransaction ts} + where + fixledgertransaction (Transaction d ed s c de co ts pr) = Transaction d ed s c de co (map fixrawposting ts) pr + where + fixrawposting (Posting s ac a c t txn) = Posting s ac (fixmixedamount a) c t txn + fixmixedamount (Mixed as) = Mixed $ map fixamount as + fixamount = (if costbasis then costOfAmount else id) . fixprice . fixcommodity + fixcommodity a = a{commodity=c} where c = canonicalcommoditymap ! symbol (commodity a) + canonicalcommoditymap = + Map.fromList [(s,firstc{precision=maxp}) | s <- commoditysymbols, + let cs = commoditymap ! s, + let firstc = head cs, + let maxp = maximum $ map precision cs + ] + commoditymap = Map.fromList [(s,commoditieswithsymbol s) | s <- commoditysymbols] + commoditieswithsymbol s = filter ((s==) . symbol) commodities + commoditysymbols = nub $ map symbol commodities + commodities = map commodity (concatMap (amounts . pamount) (journalPostings j) + ++ concatMap (amounts . hamount) (historical_prices j)) + fixprice :: Amount -> Amount + fixprice a@Amount{price=Just _} = a + fixprice a@Amount{commodity=c} = a{price=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 $ canonicaliseCommodities a + _ -> Nothing + where + canonicaliseCommodities (Mixed as) = Mixed $ map canonicaliseCommodity as + where canonicaliseCommodity a@Amount{commodity=Commodity{symbol=s}} = + a{commodity=findWithDefault (error "programmer error: canonicaliseCommodity failed") s canonicalcommoditymap} + +-- | Get just the amounts from a ledger, in the order parsed. +journalAmounts :: Journal -> [MixedAmount] +journalAmounts = map pamount . journalPostings + +-- | Get just the ammount commodities from a ledger, in the order parsed. +journalCommodities :: Journal -> [Commodity] +journalCommodities = map commodity . concatMap amounts . journalAmounts + +-- | Get just the amount precisions from a ledger, in the order parsed. +journalPrecisions :: Journal -> [Int] +journalPrecisions = map precision . journalCommodities + +-- | Close any open timelog sessions using the provided current time. +journalConvertTimeLog :: LocalTime -> Journal -> Journal +journalConvertTimeLog t l0 = l0 { jtxns = convertedTimeLog ++ jtxns l0 + , open_timelog_entries = [] + } + where convertedTimeLog = entriesFromTimeLogEntries t $ open_timelog_entries l0 + +-- | The (fully specified) date span containing all the raw ledger's transactions, +-- or DateSpan Nothing Nothing if there are none. +journalDateSpan :: Journal -> DateSpan +journalDateSpan j + | null ts = DateSpan Nothing Nothing + | otherwise = DateSpan (Just $ tdate $ head ts) (Just $ addDays 1 $ tdate $ last ts) + where + ts = sortBy (comparing tdate) $ jtxns j + +-- | Check if a set of ledger account/description patterns matches the +-- given account name or entry description. Patterns are case-insensitive +-- regular expression strings; those beginning with - are 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 = containsRegex (abspat pat) str + negateprefix = "not:" + isnegativepat = (negateprefix `isPrefixOf`) + abspat pat = if isnegativepat pat then drop (length negateprefix) pat else pat + +-- | Calculate the account tree and account balances from a journal's +-- postings, and return the results for efficient lookup. +crunchJournal :: Journal -> (Tree AccountName, Map.Map AccountName Account) +crunchJournal j = (ant,amap) + where + (ant,psof,_,inclbalof) = (groupPostings . journalPostings) j + amap = Map.fromList [(a, acctinfo a) | a <- flatten ant] + acctinfo a = Account a (psof a) (inclbalof a) + +-- | Given a list of postings, return an account name tree and three query +-- functions that fetch postings, balance, and subaccount-including +-- balance by account name. This factors out common logic from +-- cacheLedger and summarisePostingsInDateSpan. +groupPostings :: [Posting] -> (Tree AccountName, + (AccountName -> [Posting]), + (AccountName -> MixedAmount), + (AccountName -> MixedAmount)) +groupPostings ps = (ant,psof,exclbalof,inclbalof) + where + anames = sort $ nub $ map paccount ps + ant = accountNameTreeFrom $ expandAccountNames anames + allanames = flatten ant + pmap = Map.union (postingsByAccount ps) (Map.fromList [(a,[]) | a <- allanames]) + psof = (pmap !) + balmap = Map.fromList $ flatten $ calculateBalances ant psof + exclbalof = fst . (balmap !) + inclbalof = snd . (balmap !) + +-- | Add subaccount-excluding and subaccount-including balances to a tree +-- of account names somewhat efficiently, given a function that looks up +-- transactions by account name. +calculateBalances :: Tree AccountName -> (AccountName -> [Posting]) -> Tree (AccountName, (MixedAmount, MixedAmount)) +calculateBalances ant psof = addbalances ant + where + addbalances (Node a subs) = Node (a,(bal,bal+subsbal)) subs' + where + bal = sumPostings $ psof a + subsbal = sum $ map (snd . snd . root) subs' + subs' = map addbalances subs + +-- | Convert a list of postings to a map from account name to that +-- account's postings. +postingsByAccount :: [Posting] -> Map.Map AccountName [Posting] +postingsByAccount ps = m' + where + sortedps = sortBy (comparing paccount) ps + groupedps = groupBy (\p1 p2 -> paccount p1 == paccount p2) sortedps + m' = Map.fromList [(paccount $ head g, g) | g <- groupedps] diff --git a/Ledger/Ledger.hs b/Ledger/Ledger.hs new file mode 100644 --- /dev/null +++ b/Ledger/Ledger.hs @@ -0,0 +1,180 @@ +{-| + +A compound data type for efficiency. A 'Ledger' caches information derived +from a 'Journal' for easier querying. Also it typically has had +uninteresting 'Transaction's and 'Posting's filtered out. It +contains: + +- the original unfiltered 'Journal' + +- a tree of 'AccountName's + +- a map from account names to 'Account's + +- the full text of the journal file, when available + +This is the main object you'll deal with as a user of the Ledger +library. The most useful functions also have shorter, lower-case +aliases for easier interaction. Here's an example: + +> > import Ledger +> > l <- readLedger "sample.ledger" +> > accountnames l +> ["assets","assets:bank","assets:bank:checking","assets:bank:saving",... +> > accounts l +> [Account assets with 0 txns and $-1 balance,Account assets:bank with... +> > topaccounts l +> [Account assets with 0 txns and $-1 balance,Account expenses with... +> > account l "assets" +> Account assets with 0 txns and $-1 balance +> > accountsmatching ["ch"] l +> accountsmatching ["ch"] l +> [Account assets:bank:checking with 4 txns and $0 balance] +> > subaccounts l (account l "assets") +> subaccounts l (account l "assets") +> [Account assets:bank with 0 txns and $1 balance,Account assets:cash... +> > head $ transactions l +> 2008/01/01 income assets:bank:checking $1 RegularPosting +> > accounttree 2 l +> Node {rootLabel = Account top with 0 txns and 0 balance, subForest = [... +> > accounttreeat l (account l "assets") +> Just (Node {rootLabel = Account assets with 0 txns and $-1 balance, ... +> > datespan l -- disabled +> DateSpan (Just 2008-01-01) (Just 2009-01-01) +> > rawdatespan l +> DateSpan (Just 2008-01-01) (Just 2009-01-01) +> > ledgeramounts l +> [$1,$-1,$1,$-1,$1,$-1,$1,$1,$-2,$1,$-1] +> > commodities l +> [Commodity {symbol = "$", side = L, spaced = False, comma = False, ... + + +-} + +module Ledger.Ledger +where +import qualified Data.Map as Map +import Data.Map (findWithDefault, fromList) +import Ledger.Utils +import Ledger.Types +import Ledger.Account (nullacct) +import Ledger.AccountName +import Ledger.Journal +import Ledger.Posting + + +instance Show Ledger where + show l = printf "Ledger with %d transactions, %d accounts\n%s" + (length (jtxns $ journal l) + + length (jmodifiertxns $ journal l) + + length (jperiodictxns $ journal l)) + (length $ accountnames l) + (showtree $ accountnametree l) + +nullledger :: Ledger +nullledger = Ledger{ + journal = nulljournal, + accountnametree = nullaccountnametree, + accountmap = fromList [] + } + +-- | Convert a journal to a more efficient cached ledger, described above. +cacheLedger :: Journal -> Ledger +cacheLedger j = nullledger{journal=j,accountnametree=ant,accountmap=amap} + where (ant, amap) = crunchJournal j + +-- | Add (or recalculate) the cached journal info in a ledger. +cacheLedger' :: Ledger -> CachedLedger +cacheLedger' l = l{accountnametree=ant,accountmap=amap} + where (ant, amap) = crunchJournal $ journal l + +-- | Like cacheLedger, but filtering the journal first. +cacheLedger'' filterspec l@Ledger{journal=j} = l{journal=j',accountnametree=ant,accountmap=amap} + where (ant, amap) = crunchJournal j' + j' = filterJournalPostings filterspec{depth=Nothing} j + +type CachedLedger = Ledger + +-- | List a ledger's account names. +ledgerAccountNames :: Ledger -> [AccountName] +ledgerAccountNames = drop 1 . flatten . accountnametree + +-- | Get the named account from a (cached) ledger. +-- If the ledger has not been cached (with crunchJournal or +-- cacheLedger'), this returns the null account. +ledgerAccount :: Ledger -> AccountName -> Account +ledgerAccount l a = findWithDefault nullacct a $ accountmap l + +-- | List a ledger's accounts, in tree order +ledgerAccounts :: Ledger -> [Account] +ledgerAccounts = drop 1 . flatten . ledgerAccountTree 9999 + +-- | List a ledger's top-level accounts, in tree order +ledgerTopAccounts :: Ledger -> [Account] +ledgerTopAccounts = map root . branches . ledgerAccountTree 9999 + +-- | Accounts in ledger whose name matches the pattern, in tree order. +ledgerAccountsMatching :: [String] -> Ledger -> [Account] +ledgerAccountsMatching pats = filter (matchpats pats . aname) . accounts + +-- | List a ledger account's immediate subaccounts +ledgerSubAccounts :: Ledger -> Account -> [Account] +ledgerSubAccounts l Account{aname=a} = + map (ledgerAccount l) $ filter (`isSubAccountNameOf` a) $ accountnames l + +-- | List a ledger's postings, in the order parsed. +ledgerPostings :: Ledger -> [Posting] +ledgerPostings = journalPostings . journal + +-- | Get a ledger's tree of accounts to the specified depth. +ledgerAccountTree :: Int -> Ledger -> Tree Account +ledgerAccountTree depth l = treemap (ledgerAccount l) $ treeprune depth $ accountnametree l + +-- | Get a ledger's tree of accounts rooted at the specified account. +ledgerAccountTreeAt :: Ledger -> Account -> Maybe (Tree Account) +ledgerAccountTreeAt l acct = subtreeat acct $ ledgerAccountTree 9999 l + +-- | 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 + +-- | Convenience aliases. +accountnames :: Ledger -> [AccountName] +accountnames = ledgerAccountNames + +account :: Ledger -> AccountName -> Account +account = ledgerAccount + +accounts :: Ledger -> [Account] +accounts = ledgerAccounts + +topaccounts :: Ledger -> [Account] +topaccounts = ledgerTopAccounts + +accountsmatching :: [String] -> Ledger -> [Account] +accountsmatching = ledgerAccountsMatching + +subaccounts :: Ledger -> Account -> [Account] +subaccounts = ledgerSubAccounts + +postings :: Ledger -> [Posting] +postings = ledgerPostings + +commodities :: Ledger -> [Commodity] +commodities = nub . journalCommodities . journal + +accounttree :: Int -> Ledger -> Tree Account +accounttree = ledgerAccountTree + +accounttreeat :: Ledger -> Account -> Maybe (Tree Account) +accounttreeat = ledgerAccountTreeAt + +-- datespan :: Ledger -> DateSpan +-- datespan = ledgerDateSpan + +rawdatespan :: Ledger -> DateSpan +rawdatespan = journalDateSpan . journal + +ledgeramounts :: Ledger -> [MixedAmount] +ledgeramounts = journalAmounts . journal diff --git a/Ledger/Parse.hs b/Ledger/Parse.hs new file mode 100644 --- /dev/null +++ b/Ledger/Parse.hs @@ -0,0 +1,732 @@ +{-# LANGUAGE CPP #-} +{-| + +Parsers for standard ledger and timelog files. + +Here is the ledger grammar from the ledger 2.5 manual: + +@ +The ledger file format is quite simple, but also very flexible. It supports +many options, though typically the user can ignore most of them. They are +summarized below. The initial character of each line determines what the +line means, and how it should be interpreted. Allowable initial characters +are: + +NUMBER A line beginning with a number denotes an entry. It may be followed by any + number of lines, each beginning with whitespace, to denote the entry’s account + transactions. The format of the first line is: + + DATE[=EDATE] [*|!] [(CODE)] DESC + + If ‘*’ appears after the date (with optional effective date), it indicates the entry + is “cleared”, which can mean whatever the user wants it t omean. If ‘!’ appears + after the date, it indicates d the entry is “pending”; i.e., tentatively cleared from + the user’s point of view, but not yet actually cleared. If a ‘CODE’ appears in + parentheses, it may be used to indicate a check number, or the type of the + transaction. Following these is the payee, or a description of the transaction. + The format of each following transaction is: + + ACCOUNT AMOUNT [; NOTE] + + The ‘ACCOUNT’ may be surrounded by parentheses if it is a virtual + transactions, or square brackets if it is a virtual transactions that must + balance. The ‘AMOUNT’ can be followed by a per-unit transaction cost, + by specifying ‘ AMOUNT’, or a complete transaction cost with ‘\@ AMOUNT’. + Lastly, the ‘NOTE’ may specify an actual and/or effective date for the + transaction by using the syntax ‘[ACTUAL_DATE]’ or ‘[=EFFECTIVE_DATE]’ or + ‘[ACTUAL_DATE=EFFECtIVE_DATE]’. + += An automated entry. A value expression must appear after the equal sign. + After this initial line there should be a set of one or more transactions, just as + if it were normal entry. If the amounts of the transactions have no commodity, + they will be applied as modifiers to whichever real transaction is matched by + the value expression. + +~ A period entry. A period expression must appear after the tilde. + After this initial line there should be a set of one or more transactions, just as + if it were normal entry. + +! A line beginning with an exclamation mark denotes a command directive. It + must be immediately followed by the command word. The supported commands + are: + + ‘!include’ + Include the stated ledger file. + ‘!account’ + The account name is given is taken to be the parent of all transac- + tions that follow, until ‘!end’ is seen. + ‘!end’ Ends an account block. + +; A line beginning with a colon indicates a comment, and is ignored. + +Y If a line begins with a capital Y, it denotes the year used for all subsequent + entries that give a date without a year. The year should appear immediately + after the Y, for example: ‘Y2004’. This is useful at the beginning of a file, to + specify the year for that file. If all entries specify a year, however, this command + has no effect. + + +P Specifies a historical price for a commodity. These are usually found in a pricing + history file (see the ‘-Q’ option). The syntax is: + + P DATE SYMBOL PRICE + +N SYMBOL Indicates that pricing information is to be ignored for a given symbol, nor will + quotes ever be downloaded for that symbol. Useful with a home currency, such + as the dollar ($). It is recommended that these pricing options be set in the price + database file, which defaults to ‘~/.pricedb’. The syntax for this command is: + + N SYMBOL + + +D AMOUNT Specifies the default commodity to use, by specifying an amount in the expected + format. The entry command will use this commodity as the default when none + other can be determined. This command may be used multiple times, to set + the default flags for different commodities; whichever is seen last is used as the + default commodity. For example, to set US dollars as the default commodity, + while also setting the thousands flag and decimal flag for that commodity, use: + + D $1,000.00 + +C AMOUNT1 = AMOUNT2 + Specifies a commodity conversion, where the first amount is given to be equiv- + alent to the second amount. The first amount should use the decimal precision + desired during reporting: + + C 1.00 Kb = 1024 bytes + +i, o, b, h + These four relate to timeclock support, which permits ledger to read timelog + files. See the timeclock’s documentation for more info on the syntax of its + timelog files. +@ + +Here is the timelog grammar 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. +@ + +Example: + +@ +i 2007/03/10 12:26:00 hledger +o 2007/03/10 17:26:02 +@ + +-} + +module Ledger.Parse +where +import Control.Monad.Error (ErrorT(..), MonadIO, liftIO, throwError, catchError) +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Char +import Text.ParserCombinators.Parsec.Combinator +import System.Directory +#if __GLASGOW_HASKELL__ <= 610 +import Prelude hiding (readFile, putStr, putStrLn, print, getContents) +import System.IO.UTF8 +#endif +import Ledger.Utils +import Ledger.Types +import Ledger.Dates +import Ledger.AccountName (accountNameFromComponents,accountNameComponents) +import Ledger.Amount +import Ledger.Transaction +import Ledger.Posting +import Ledger.Journal +import Ledger.Commodity (dollars,dollar,unknown) +import System.FilePath(takeDirectory,combine) + + +-- | A JournalUpdate is some transformation of a "Journal". It can do I/O +-- or raise an error. +type JournalUpdate = ErrorT String IO (Journal -> Journal) + +-- | Some context kept during parsing. +data LedgerFileCtx = Ctx { + ctxYear :: !(Maybe Integer) -- ^ the default year most recently specified with Y + , ctxCommod :: !(Maybe String) -- ^ I don't know + , ctxAccount :: ![String] -- ^ the current stack of parent accounts specified by !account + } deriving (Read, Show) + +emptyCtx :: LedgerFileCtx +emptyCtx = Ctx { ctxYear = Nothing, ctxCommod = Nothing, ctxAccount = [] } + +setYear :: Integer -> GenParser tok LedgerFileCtx () +setYear y = updateState (\ctx -> ctx{ctxYear=Just y}) + +getYear :: GenParser tok LedgerFileCtx (Maybe Integer) +getYear = liftM ctxYear getState + +pushParentAccount :: String -> GenParser tok LedgerFileCtx () +pushParentAccount parent = updateState addParentAccount + where addParentAccount ctx0 = ctx0 { ctxAccount = normalize parent : ctxAccount ctx0 } + normalize = (++ ":") + +popParentAccount :: GenParser tok LedgerFileCtx () +popParentAccount = do ctx0 <- getState + case ctxAccount ctx0 of + [] -> unexpected "End of account block with no beginning" + (_:rest) -> setState $ ctx0 { ctxAccount = rest } + +getParentAccount :: GenParser tok LedgerFileCtx String +getParentAccount = liftM (concat . reverse . ctxAccount) getState + +expandPath :: (MonadIO m) => SourcePos -> FilePath -> m FilePath +expandPath pos fp = liftM mkRelative (expandHome fp) + where + mkRelative = combine (takeDirectory (sourceName pos)) + expandHome inname | "~/" `isPrefixOf` inname = do homedir <- liftIO getHomeDirectory + return $ homedir ++ drop 1 inname + | otherwise = return inname + +-- let's get to it + +-- | Parses a ledger file or timelog file to a "Journal", or gives an +-- error. Requires the current (local) time to calculate any unfinished +-- timelog sessions, we pass it in for repeatability. +parseLedgerFile :: LocalTime -> FilePath -> ErrorT String IO Journal +parseLedgerFile t "-" = liftIO getContents >>= parseLedger t "-" +parseLedgerFile t f = liftIO (readFile f) >>= parseLedger t f + +-- | Like parseLedgerFile, but parses a string. A file path is still +-- provided to save in the resulting journal. +parseLedger :: LocalTime -> FilePath -> String -> ErrorT String IO Journal +parseLedger reftime inname intxt = + case runParser ledgerFile emptyCtx inname intxt of + Right m -> liftM (journalConvertTimeLog reftime) $ m `ap` return nulljournal + Left err -> throwError $ show err -- XXX raises an uncaught exception if we have a parsec user error, eg from many ? + +-- parsers + +-- | Top-level journal parser. Returns a single composite, I/O performing, +-- error-raising "JournalUpdate" which can be applied to an empty journal +-- to get the final result. +ledgerFile :: GenParser Char LedgerFileCtx JournalUpdate +ledgerFile = do items <- many ledgerItem + eof + return $ liftM (foldr (.) id) $ sequence items + 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 + ledgerItem = choice [ ledgerExclamationDirective + , liftM (return . addTransaction) ledgerTransaction + , liftM (return . addModifierTransaction) ledgerModifierTransaction + , liftM (return . addPeriodicTransaction) ledgerPeriodicTransaction + , liftM (return . addHistoricalPrice) ledgerHistoricalPrice + , ledgerDefaultYear + , ledgerIgnoredPriceCommodity + , ledgerTagDirective + , ledgerEndTagDirective + , emptyLine >> return (return id) + , liftM (return . addTimeLogEntry) timelogentry + ] + +emptyLine :: GenParser Char st () +emptyLine = do many spacenonewline + optional $ (char ';' "comment") >> many (noneOf "\n") + newline + return () + +ledgercomment :: GenParser Char st String +ledgercomment = do + many1 $ char ';' + many spacenonewline + many (noneOf "\n") + "comment" + +ledgercommentline :: GenParser Char st String +ledgercommentline = do + many spacenonewline + s <- ledgercomment + optional newline + eof + return s + "comment" + +ledgerExclamationDirective :: GenParser Char LedgerFileCtx JournalUpdate +ledgerExclamationDirective = do + char '!' "directive" + directive <- many nonspace + case directive of + "include" -> ledgerInclude + "account" -> ledgerAccountBegin + "end" -> ledgerAccountEnd + _ -> mzero + +ledgerInclude :: GenParser Char LedgerFileCtx JournalUpdate +ledgerInclude = do many1 spacenonewline + filename <- restofline + outerState <- getState + outerPos <- getPosition + let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n" + return $ do contents <- expandPath outerPos filename >>= readFileE outerPos + case runParser ledgerFile outerState filename contents of + Right l -> l `catchError` (throwError . (inIncluded ++)) + Left perr -> throwError $ inIncluded ++ show perr + where readFileE outerPos filename = ErrorT $ liftM Right (readFile filename) `catch` leftError + where leftError err = return $ Left $ currentPos ++ whileReading ++ show err + currentPos = show outerPos + whileReading = " reading " ++ show filename ++ ":\n" + +ledgerAccountBegin :: GenParser Char LedgerFileCtx JournalUpdate +ledgerAccountBegin = do many1 spacenonewline + parent <- ledgeraccountname + newline + pushParentAccount parent + return $ return id + +ledgerAccountEnd :: GenParser Char LedgerFileCtx JournalUpdate +ledgerAccountEnd = popParentAccount >> return (return id) + +ledgerModifierTransaction :: GenParser Char LedgerFileCtx ModifierTransaction +ledgerModifierTransaction = do + char '=' "modifier transaction" + many spacenonewline + valueexpr <- restofline + postings <- ledgerpostings + return $ ModifierTransaction valueexpr postings + +ledgerPeriodicTransaction :: GenParser Char LedgerFileCtx PeriodicTransaction +ledgerPeriodicTransaction = do + char '~' "periodic transaction" + many spacenonewline + periodexpr <- restofline + postings <- ledgerpostings + return $ PeriodicTransaction periodexpr postings + +ledgerHistoricalPrice :: GenParser Char LedgerFileCtx HistoricalPrice +ledgerHistoricalPrice = do + char 'P' "historical price" + many spacenonewline + date <- try (do {LocalTime d _ <- ledgerdatetime; return d}) <|> ledgerdate -- a time is ignored + many1 spacenonewline + symbol <- commoditysymbol + many spacenonewline + price <- someamount + restofline + return $ HistoricalPrice date symbol price + +ledgerIgnoredPriceCommodity :: GenParser Char LedgerFileCtx JournalUpdate +ledgerIgnoredPriceCommodity = do + char 'N' "ignored-price commodity" + many1 spacenonewline + commoditysymbol + restofline + return $ return id + +ledgerDefaultCommodity :: GenParser Char LedgerFileCtx JournalUpdate +ledgerDefaultCommodity = do + char 'D' "default commodity" + many1 spacenonewline + someamount + restofline + return $ return id + +ledgerCommodityConversion :: GenParser Char LedgerFileCtx JournalUpdate +ledgerCommodityConversion = do + char 'C' "commodity conversion" + many1 spacenonewline + someamount + many spacenonewline + char '=' + many spacenonewline + someamount + restofline + return $ return id + +ledgerTagDirective :: GenParser Char LedgerFileCtx JournalUpdate +ledgerTagDirective = do + string "tag" "tag directive" + many1 spacenonewline + _ <- many1 nonspace + restofline + return $ return id + +ledgerEndTagDirective :: GenParser Char LedgerFileCtx JournalUpdate +ledgerEndTagDirective = do + string "end tag" "end tag directive" + restofline + return $ return id + +-- like ledgerAccountBegin, updates the LedgerFileCtx +ledgerDefaultYear :: GenParser Char LedgerFileCtx JournalUpdate +ledgerDefaultYear = do + char 'Y' "default year" + many spacenonewline + y <- many1 digit + let y' = read y + guard (y' >= 1000) + setYear y' + return $ return id + +-- | Try to parse a ledger entry. If we successfully parse an entry, +-- check it can be balanced, and fail if not. +ledgerTransaction :: GenParser Char LedgerFileCtx Transaction +ledgerTransaction = do + date <- ledgerdate "transaction" + edate <- try (ledgereffectivedate date "effective date") <|> return Nothing + status <- ledgerstatus + code <- ledgercode + description <- many1 spacenonewline >> liftM rstrip (many (noneOf ";\n") "description") + comment <- ledgercomment <|> return "" + restofline + postings <- ledgerpostings + let t = txnTieKnot $ Transaction date edate status code description comment postings "" + case balanceTransaction t of + Right t' -> return t' + Left err -> fail err + +ledgerdate :: GenParser Char LedgerFileCtx Day +ledgerdate = (try ledgerfulldate <|> ledgerpartialdate) "full or partial date" + +ledgerfulldate :: GenParser Char LedgerFileCtx Day +ledgerfulldate = do + (y,m,d) <- ymd + return $ fromGregorian (read y) (read m) (read d) + +-- | Match a partial M/D date in a ledger, and also require that a default +-- year directive was previously encountered. +ledgerpartialdate :: GenParser Char LedgerFileCtx Day +ledgerpartialdate = do + (_,m,d) <- md + y <- getYear + when (y==Nothing) $ fail "partial date found, but no default year specified" + return $ fromGregorian (fromJust y) (read m) (read d) + +ledgerdatetime :: GenParser Char LedgerFileCtx LocalTime +ledgerdatetime = do + day <- ledgerdate + many1 spacenonewline + h <- many1 digit + char ':' + m <- many1 digit + s <- optionMaybe $ do + char ':' + many1 digit + let tod = TimeOfDay (read h) (read m) (maybe 0 (fromIntegral.read) s) + return $ LocalTime day tod + +ledgereffectivedate :: Day -> GenParser Char LedgerFileCtx (Maybe Day) +ledgereffectivedate actualdate = do + char '=' + -- kludgy way to use actual 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 actualdate ledgerdate + return $ Just edate + +ledgerstatus :: GenParser Char st Bool +ledgerstatus = try (do { many1 spacenonewline; char '*' "status"; return True } ) <|> return False + +ledgercode :: GenParser Char st String +ledgercode = try (do { many1 spacenonewline; char '(' "code"; code <- anyChar `manyTill` char ')'; return code } ) <|> return "" + +ledgerpostings :: GenParser Char LedgerFileCtx [Posting] +ledgerpostings = do + -- complicated to handle intermixed comment lines.. please make me better. + ctx <- getState + let parses p = isRight . parseWithCtx ctx p + ls <- many1 $ try linebeginningwithspaces + let ls' = filter (not . (ledgercommentline `parses`)) ls + guard (not $ null ls') + return $ map (fromparse . parseWithCtx ctx ledgerposting) ls' + "postings" + +linebeginningwithspaces :: GenParser Char st String +linebeginningwithspaces = do + sp <- many1 spacenonewline + c <- nonspace + cs <- restofline + return $ sp ++ (c:cs) ++ "\n" + +ledgerposting :: GenParser Char LedgerFileCtx Posting +ledgerposting = do + many1 spacenonewline + status <- ledgerstatus + account <- transactionaccountname + let (ptype, account') = (postingTypeFromAccountName account, unbracket account) + amount <- postingamount + many spacenonewline + comment <- ledgercomment <|> return "" + newline + return (Posting status account' amount comment ptype Nothing) + +-- qualify with the parent account from parsing context +transactionaccountname :: GenParser Char LedgerFileCtx AccountName +transactionaccountname = liftM2 (++) getParentAccount ledgeraccountname + +-- | Parse an account name. Account names may have single spaces inside +-- them, and are terminated by two or more spaces. They should have one or +-- more components of at least one character, separated by the account +-- separator char. +ledgeraccountname :: GenParser Char st AccountName +ledgeraccountname = do + a <- many1 (nonspace <|> singlespace) + let a' = striptrailingspace a + when (accountNameFromComponents (accountNameComponents a') /= a') + (fail $ "accountname seems ill-formed: "++a') + return a' + where + singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}}) + -- couldn't avoid consuming a final space sometimes, harmless + striptrailingspace s = if last s == ' ' then init s else s + +-- accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace +-- "account name character (non-bracket, non-parenthesis, non-whitespace)" + +-- | Parse an amount, with an optional left or right currency symbol and +-- optional price. +postingamount :: GenParser Char st MixedAmount +postingamount = + try (do + many1 spacenonewline + someamount <|> return missingamt + ) <|> return missingamt + +someamount :: GenParser Char st MixedAmount +someamount = try leftsymbolamount <|> try rightsymbolamount <|> nosymbolamount + +leftsymbolamount :: GenParser Char st MixedAmount +leftsymbolamount = do + sym <- commoditysymbol + sp <- many spacenonewline + (q,p,comma) <- amountquantity + pri <- priceamount + let c = Commodity {symbol=sym,side=L,spaced=not $ null sp,comma=comma,precision=p} + return $ Mixed [Amount c q pri] + "left-symbol amount" + +rightsymbolamount :: GenParser Char st MixedAmount +rightsymbolamount = do + (q,p,comma) <- amountquantity + sp <- many spacenonewline + sym <- commoditysymbol + pri <- priceamount + let c = Commodity {symbol=sym,side=R,spaced=not $ null sp,comma=comma,precision=p} + return $ Mixed [Amount c q pri] + "right-symbol amount" + +nosymbolamount :: GenParser Char st MixedAmount +nosymbolamount = do + (q,p,comma) <- amountquantity + pri <- priceamount + let c = Commodity {symbol="",side=L,spaced=False,comma=comma,precision=p} + return $ Mixed [Amount c q pri] + "no-symbol amount" + +commoditysymbol :: GenParser Char st String +commoditysymbol = (quotedcommoditysymbol <|> + many1 (noneOf "0123456789-.@;\n \"") + ) "commodity symbol" + +quotedcommoditysymbol :: GenParser Char st String +quotedcommoditysymbol = do + char '"' + s <- many1 $ noneOf "-.@;\n \"" + char '"' + return s + +priceamount :: GenParser Char st (Maybe MixedAmount) +priceamount = + try (do + many spacenonewline + char '@' + many spacenonewline + a <- someamount + return $ Just a + ) <|> return Nothing + +-- gawd.. trying to parse a ledger number without error: + +-- | Parse a ledger-style numeric quantity and also return the number of +-- digits to the right of the decimal point and whether thousands are +-- separated by comma. +amountquantity :: GenParser Char st (Double, Int, Bool) +amountquantity = do + sign <- optionMaybe $ string "-" + (intwithcommas,frac) <- numberparts + let comma = ',' `elem` intwithcommas + let precision = length frac + -- read the actual value. We expect this read to never fail. + let int = filter (/= ',') intwithcommas + let int' = if null int then "0" else int + let frac' = if null frac then "0" else frac + let sign' = fromMaybe "" sign + let quantity = read $ sign'++int'++"."++frac' + return (quantity, precision, comma) + "commodity quantity" + +-- | parse the two strings of digits before and after a possible decimal +-- point. The integer part may contain commas, or either part may be +-- empty, or there may be no point. +numberparts :: GenParser Char st (String,String) +numberparts = numberpartsstartingwithdigit <|> numberpartsstartingwithpoint + +numberpartsstartingwithdigit :: GenParser Char st (String,String) +numberpartsstartingwithdigit = do + let digitorcomma = digit <|> char ',' + first <- digit + rest <- many digitorcomma + frac <- try (do {char '.'; many digit}) <|> return "" + return (first:rest,frac) + +numberpartsstartingwithpoint :: GenParser Char st (String,String) +numberpartsstartingwithpoint = do + char '.' + frac <- many1 digit + return ("",frac) + + +-- | Parse a timelog entry. +timelogentry :: GenParser Char LedgerFileCtx TimeLogEntry +timelogentry = do + code <- oneOf "bhioO" + many1 spacenonewline + datetime <- ledgerdatetime + comment <- optionMaybe (many1 spacenonewline >> liftM2 (++) getParentAccount restofline) + return $ TimeLogEntry (read [code]) datetime (fromMaybe "" comment) + + +-- | Parse a hledger display expression, which is a simple date test like +-- "d>[DATE]" or "d<=[DATE]", and return a "Posting"-matching predicate. +datedisplayexpr :: GenParser Char st (Posting -> Bool) +datedisplayexpr = do + char 'd' + op <- compareop + char '[' + (y,m,d) <- smartdate + char ']' + let date = parsedate $ printf "%04s/%02s/%02s" y m d + test op = return $ (`op` date) . postingDate + case op of + "<" -> test (<) + "<=" -> test (<=) + "=" -> test (==) + "==" -> test (==) + ">=" -> test (>=) + ">" -> test (>) + _ -> mzero + +compareop = choice $ map (try . string) ["<=",">=","==","<","=",">"] + + +tests_Parse = TestList [ + + "ledgerTransaction" ~: do + assertParseEqual (parseWithCtx emptyCtx ledgerTransaction entry1_str) entry1 + assertBool "ledgerTransaction should not parse just a date" + $ isLeft $ parseWithCtx emptyCtx ledgerTransaction "2009/1/1\n" + assertBool "ledgerTransaction should require some postings" + $ isLeft $ parseWithCtx emptyCtx ledgerTransaction "2009/1/1 a\n" + let t = parseWithCtx emptyCtx ledgerTransaction "2009/1/1 a ;comment\n b 1\n" + assertBool "ledgerTransaction should not include a comment in the description" + $ either (const False) ((== "a") . tdescription) t + + ,"ledgerModifierTransaction" ~: do + assertParse (parseWithCtx emptyCtx ledgerModifierTransaction "= (some value expr)\n some:postings 1\n") + + ,"ledgerPeriodicTransaction" ~: do + assertParse (parseWithCtx emptyCtx ledgerPeriodicTransaction "~ (some period expr)\n some:postings 1\n") + + ,"ledgerExclamationDirective" ~: do + assertParse (parseWithCtx emptyCtx ledgerExclamationDirective "!include /some/file.x\n") + assertParse (parseWithCtx emptyCtx ledgerExclamationDirective "!account some:account\n") + assertParse (parseWithCtx emptyCtx (ledgerExclamationDirective >> ledgerExclamationDirective) "!account a\n!end\n") + + ,"ledgercommentline" ~: do + assertParse (parseWithCtx emptyCtx ledgercommentline "; some comment \n") + assertParse (parseWithCtx emptyCtx ledgercommentline " \t; x\n") + assertParse (parseWithCtx emptyCtx ledgercommentline ";x") + + ,"ledgerDefaultYear" ~: do + assertParse (parseWithCtx emptyCtx ledgerDefaultYear "Y 2010\n") + assertParse (parseWithCtx emptyCtx ledgerDefaultYear "Y 10001\n") + + ,"ledgerHistoricalPrice" ~: + assertParseEqual (parseWithCtx emptyCtx ledgerHistoricalPrice "P 2004/05/01 XYZ $55.00\n") (HistoricalPrice (parsedate "2004/05/01") "XYZ" $ Mixed [dollars 55]) + + ,"ledgerIgnoredPriceCommodity" ~: do + assertParse (parseWithCtx emptyCtx ledgerIgnoredPriceCommodity "N $\n") + + ,"ledgerDefaultCommodity" ~: do + assertParse (parseWithCtx emptyCtx ledgerDefaultCommodity "D $1,000.0\n") + + ,"ledgerCommodityConversion" ~: do + assertParse (parseWithCtx emptyCtx ledgerCommodityConversion "C 1h = $50.00\n") + + ,"ledgerTagDirective" ~: do + assertParse (parseWithCtx emptyCtx ledgerTagDirective "tag foo \n") + + ,"ledgerEndTagDirective" ~: do + assertParse (parseWithCtx emptyCtx ledgerEndTagDirective "end tag \n") + + ,"ledgeraccountname" ~: do + assertBool "ledgeraccountname parses a normal accountname" (isRight $ parsewith ledgeraccountname "a:b:c") + assertBool "ledgeraccountname rejects an empty inner component" (isLeft $ parsewith ledgeraccountname "a::c") + assertBool "ledgeraccountname rejects an empty leading component" (isLeft $ parsewith ledgeraccountname ":b:c") + assertBool "ledgeraccountname rejects an empty trailing component" (isLeft $ parsewith ledgeraccountname "a:b:") + + ,"ledgerposting" ~: do + assertParseEqual (parseWithCtx emptyCtx ledgerposting " expenses:food:dining $10.00\n") + (Posting False "expenses:food:dining" (Mixed [dollars 10]) "" RegularPosting Nothing) + assertBool "ledgerposting parses a quoted commodity with numbers" + (isRight $ parseWithCtx emptyCtx ledgerposting " a 1 \"DE123\"\n") + + ,"someamount" ~: do + let -- | compare a parse result with a MixedAmount, showing the debug representation for clarity + assertMixedAmountParse parseresult mixedamount = + (either (const "parse error") showMixedAmountDebug parseresult) ~?= (showMixedAmountDebug mixedamount) + assertMixedAmountParse (parsewith someamount "1 @ $2") + (Mixed [Amount unknown 1 (Just $ Mixed [Amount dollar{precision=0} 2 Nothing])]) + + ,"postingamount" ~: do + assertParseEqual (parseWithCtx emptyCtx postingamount " $47.18") (Mixed [dollars 47.18]) + assertParseEqual (parseWithCtx emptyCtx postingamount " $1.") + (Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} 1 Nothing]) + + ] + +entry1_str = unlines + ["2007/01/28 coopportunity" + ," expenses:food:groceries $47.18" + ," assets:checking $-47.18" + ,"" + ] + +entry1 = + txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" + [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting Nothing, + Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting Nothing] "" + + diff --git a/Ledger/Posting.hs b/Ledger/Posting.hs new file mode 100644 --- /dev/null +++ b/Ledger/Posting.hs @@ -0,0 +1,94 @@ +{-| + +A 'Posting' represents a 'MixedAmount' being added to or subtracted from a +single 'Account'. Each 'Transaction' contains two or more postings which +should add up to 0. Postings also reference their parent transaction, so +we can get a date or description for a posting (from the transaction). + +-} + +module Ledger.Posting +where +import Ledger.Utils +import Ledger.Types +import Ledger.Amount +import Ledger.AccountName +import Ledger.Dates (nulldate) + + +instance Show Posting where show = showPosting + +nullposting = Posting False "" nullmixedamt "" RegularPosting Nothing + +showPosting :: Posting -> String +showPosting (Posting{paccount=a,pamount=amt,pcomment=com,ptype=t}) = + concatTopPadded [showaccountname a ++ " ", showamount amt, comment] + 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 . showMixedAmountOrZero + comment = if null com then "" else " ; " ++ com +-- XXX refactor +showPostingForRegister (Posting{paccount=a,pamount=amt,ptype=t}) = + concatTopPadded [showaccountname a ++ " ", showamount amt] + 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 . showMixedAmountOrZeroWithoutPrice + +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 = (/= missingamt) . pamount + +postingTypeFromAccountName a + | head a == '[' && last a == ']' = BalancedVirtualPosting + | head a == '(' && last a == ')' = VirtualPosting + | otherwise = RegularPosting + +accountNamesFromPostings :: [Posting] -> [AccountName] +accountNamesFromPostings = nub . map paccount + +sumPostings :: [Posting] -> MixedAmount +sumPostings = sumMixedAmountsPreservingHighestPrecision . map pamount + +postingDate :: Posting -> Day +postingDate p = maybe nulldate tdate $ ptransaction p + +postingCleared :: Posting -> Bool +postingCleared p = maybe False tstatus $ ptransaction p + +-- | Does this posting fall within the given date span ? +isPostingInDateSpan :: DateSpan -> Posting -> Bool +isPostingInDateSpan (DateSpan Nothing Nothing) _ = True +isPostingInDateSpan (DateSpan Nothing (Just e)) p = postingDate p < e +isPostingInDateSpan (DateSpan (Just b) Nothing) p = postingDate p >= b +isPostingInDateSpan (DateSpan (Just b) (Just e)) p = d >= b && d < e where d = postingDate p + +isEmptyPosting :: Posting -> Bool +isEmptyPosting = isZeroMixedAmount . pamount + +-- | Get the minimal date span which contains all the postings, or +-- DateSpan Nothing Nothing 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 + diff --git a/Ledger/TimeLog.hs b/Ledger/TimeLog.hs new file mode 100644 --- /dev/null +++ b/Ledger/TimeLog.hs @@ -0,0 +1,90 @@ +{-| + +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 Ledger.TimeLog +where +import Ledger.Utils +import Ledger.Types +import Ledger.Dates +import Ledger.Commodity +import Ledger.Transaction + +instance Show TimeLogEntry where + show t = printf "%s %s %s" (show $ tlcode t) (show $ tldatetime t) (tlcomment t) + +instance Show TimeLogCode where + show SetBalance = "b" + show SetRequiredHours = "h" + show In = "i" + show Out = "o" + show FinalOut = "O" + +instance Read TimeLogCode where + readsPrec _ ('b' : xs) = [(SetBalance, xs)] + readsPrec _ ('h' : xs) = [(SetRequiredHours, xs)] + readsPrec _ ('i' : xs) = [(In, xs)] + readsPrec _ ('o' : xs) = [(Out, xs)] + readsPrec _ ('O' : xs) = [(FinalOut, xs)] + readsPrec _ _ = [] + +-- | Convert time log entries to ledger 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. +entriesFromTimeLogEntries :: LocalTime -> [TimeLogEntry] -> [Transaction] +entriesFromTimeLogEntries _ [] = [] +entriesFromTimeLogEntries now [i] + | odate > idate = entryFromTimeLogInOut i o' : entriesFromTimeLogEntries now [i',o] + | otherwise = [entryFromTimeLogInOut i o] + where + o = TimeLogEntry Out end "" + end = if itime > now then itime else now + (itime,otime) = (tldatetime i,tldatetime o) + (idate,odate) = (localDay itime,localDay otime) + o' = o{tldatetime=itime{localDay=idate, localTimeOfDay=TimeOfDay 23 59 59}} + i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}} +entriesFromTimeLogEntries now (i:o:rest) + | odate > idate = entryFromTimeLogInOut i o' : entriesFromTimeLogEntries now (i':o:rest) + | otherwise = entryFromTimeLogInOut i o : entriesFromTimeLogEntries 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 ledger +-- entry, representing the time expenditure. Note this entry is not balanced, +-- since we omit the \"assets:time\" transaction for simpler output. +entryFromTimeLogInOut :: TimeLogEntry -> TimeLogEntry -> Transaction +entryFromTimeLogInOut i o + | otime >= itime = t + | otherwise = + error $ "clock-out time less than clock-in time in:\n" ++ showTransaction t + where + t = Transaction { + tdate = idate, + teffectivedate = Nothing, + tstatus = True, + tcode = "", + tdescription = showtime itod ++ "-" ++ showtime otod, + tcomment = "", + tpostings = ps, + tpreceding_comment_lines="" + } + showtime = take 5 . show + acctname = tlcomment i + itime = tldatetime i + otime = tldatetime o + itod = localTimeOfDay itime + otod = localTimeOfDay otime + idate = localDay itime + hrs = elapsedSeconds (toutc otime) (toutc itime) / 3600 where toutc = localTimeToUTC utc + amount = Mixed [hours hrs] + ps = [Posting{pstatus=False,paccount=acctname,pamount=amount, + pcomment="",ptype=RegularPosting,ptransaction=Just t} + --,Posting "assets:time" (-amount) "" RegularPosting + ] diff --git a/Ledger/Transaction.hs b/Ledger/Transaction.hs new file mode 100644 --- /dev/null +++ b/Ledger/Transaction.hs @@ -0,0 +1,250 @@ +{-| + +A 'Transaction' represents a single balanced entry in the ledger file. It +normally contains two or more balanced 'Posting's. + +-} + +module Ledger.Transaction +where +import Ledger.Utils +import Ledger.Types +import Ledger.Dates +import Ledger.Posting +import Ledger.Amount +import Ledger.Commodity (dollars, dollar, unknown) + +instance Show Transaction where show = showTransactionUnelided + +instance Show ModifierTransaction where + show t = "= " ++ mtvalueexpr t ++ "\n" ++ unlines (map show (mtpostings t)) + +instance Show PeriodicTransaction where + show t = "~ " ++ ptperiodicexpr t ++ "\n" ++ unlines (map show (ptpostings t)) + +nulltransaction :: Transaction +nulltransaction = Transaction { + tdate=nulldate, + teffectivedate=Nothing, + tstatus=False, + tcode="", + tdescription="", + tcomment="", + tpostings=[], + tpreceding_comment_lines="" + } + +{-| +Show a ledger entry, 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 False + +showTransactionUnelided :: Transaction -> String +showTransactionUnelided = showTransaction' False False + +showTransactionForPrint :: Bool -> Transaction -> String +showTransactionForPrint effective = showTransaction' False effective + +showTransaction' :: Bool -> Bool -> Transaction -> String +showTransaction' elide effective t = + unlines $ [description] ++ showpostings (tpostings t) ++ [""] + where + description = concat [date, status, code, desc, comment] + date | effective = showdate $ fromMaybe (tdate t) $ teffectivedate t + | otherwise = showdate (tdate t) ++ maybe "" showedate (teffectivedate t) + status = if tstatus t then " *" else "" + code = if length (tcode t) > 0 then printf " (%s)" $ tcode t else "" + desc = ' ' : tdescription t + comment = if null com then "" else " ; " ++ com where com = tcomment t + showdate = printf "%-10s" . showDate + showedate = printf "=%s" . showdate + showpostings ps + | elide && length ps > 1 && isTransactionBalanced t + = map showposting (init ps) ++ [showpostingnoamt (last ps)] + | otherwise = map showposting ps + where + showposting p = showacct p ++ " " ++ showamount (pamount p) ++ showcomment (pcomment p) + showpostingnoamt p = rstrip $ showacct p ++ " " ++ showcomment (pcomment p) + showacct p = " " ++ showstatus p ++ printf (printf "%%-%ds" w) (showAccountName Nothing (ptype p) (paccount p)) + w = maximum $ map (length . paccount) ps + showamount = printf "%12s" . showMixedAmountOrZero + showcomment s = if null s then "" else " ; "++s + showstatus p = if pstatus p then "* " else "" + +-- | 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++"]" + +realPostings :: Transaction -> [Posting] +realPostings = filter isReal . tpostings + +virtualPostings :: Transaction -> [Posting] +virtualPostings = filter isVirtual . tpostings + +balancedVirtualPostings :: Transaction -> [Posting] +balancedVirtualPostings = filter isBalancedVirtual . 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 :: Transaction -> Bool +isTransactionBalanced t = isReallyZeroMixedAmountCost rsum && isReallyZeroMixedAmountCost bvsum + where (rsum, _, bvsum) = transactionPostingBalances t + +-- | Ensure that this entry is balanced, possibly auto-filling a missing +-- amount first. We can auto-fill if there is just one non-virtual +-- transaction without an amount. The auto-filled balance will be +-- converted to cost basis if possible. If the entry can not be balanced, +-- return an error message instead. +balanceTransaction :: Transaction -> Either String Transaction +balanceTransaction t@Transaction{tpostings=ps} + | length missingamounts' > 1 = Left $ printerr "could not balance this transaction (too many missing amounts)" + | not $ isTransactionBalanced t' = Left $ printerr $ nonzerobalanceerror t' + | otherwise = Right t' + where + (withamounts, missingamounts) = partition hasAmount $ filter isReal ps + (_, missingamounts') = partition hasAmount ps + t' = t{tpostings=ps'} + ps' | length missingamounts == 1 = map balance ps + | otherwise = ps + where + balance p | isReal p && not (hasAmount p) = p{pamount = costOfMixedAmount (-otherstotal)} + | otherwise = p + where otherstotal = sum $ map pamount withamounts + 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 " ++ show rsum + bvmsg | isReallyZeroMixedAmountCost bvsum = "" + | otherwise = "balanced virtual postings are off by " ++ show bvsum + sep = if not (null rmsg) && not (null bvmsg) then "; " else "" + +-- | Convert the primary date to either the actual or effective date. +ledgerTransactionWithDate :: WhichDate -> Transaction -> Transaction +ledgerTransactionWithDate ActualDate t = t +ledgerTransactionWithDate EffectiveDate t = txnTieKnot t{tdate=fromMaybe (tdate t) (teffectivedate t)} + + +-- | Ensure a transaction's postings refer back to it. +txnTieKnot :: Transaction -> Transaction +txnTieKnot t@Transaction{tpostings=ps} = t{tpostings=map (settxn t) ps} + +-- | Set a posting's parent transaction. +settxn :: Transaction -> Posting -> Posting +settxn t p = p{ptransaction=Just t} + +tests_Transaction = TestList [ + "showTransaction" ~: do + assertEqual "show a balanced transaction, eliding last amount" + (unlines + ["2007/01/28 coopportunity" + ," expenses:food:groceries $47.18" + ," assets:checking" + ,"" + ]) + (let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" + [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting (Just t) + ,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting (Just t) + ] "" + in showTransaction t) + + ,"showTransaction" ~: do + assertEqual "show a balanced transaction, no eliding" + (unlines + ["2007/01/28 coopportunity" + ," expenses:food:groceries $47.18" + ," assets:checking $-47.18" + ,"" + ]) + (let t = Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" + [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting (Just t) + ,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting (Just t) + ] "" + in showTransactionUnelided t) + + -- document some cases that arise in debug/testing: + ,"showTransaction" ~: do + assertEqual "show an unbalanced transaction, should not elide" + (unlines + ["2007/01/28 coopportunity" + ," expenses:food:groceries $47.18" + ," assets:checking $-47.19" + ,"" + ]) + (showTransaction + (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" + [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting Nothing + ,Posting False "assets:checking" (Mixed [dollars (-47.19)]) "" RegularPosting Nothing + ] "")) + + ,"showTransaction" ~: do + assertEqual "show an unbalanced transaction with one posting, should not elide" + (unlines + ["2007/01/28 coopportunity" + ," expenses:food:groceries $47.18" + ,"" + ]) + (showTransaction + (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" + [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting Nothing + ] "")) + + ,"showTransaction" ~: do + assertEqual "show a transaction with one posting and a missing amount" + (unlines + ["2007/01/28 coopportunity" + ," expenses:food:groceries " + ,"" + ]) + (showTransaction + (txnTieKnot $ Transaction (parsedate "2007/01/28") Nothing False "" "coopportunity" "" + [Posting False "expenses:food:groceries" missingamt "" RegularPosting Nothing + ] "")) + + ,"showTransaction" ~: do + assertEqual "show a transaction with a priced commodityless amount" + (unlines + ["2010/01/01 x" + ," a 1 @ $2" + ," b " + ,"" + ]) + (showTransaction + (txnTieKnot $ Transaction (parsedate "2010/01/01") Nothing False "" "x" "" + [Posting False "a" (Mixed [Amount unknown 1 (Just $ Mixed [Amount dollar{precision=0} 2 Nothing])]) "" RegularPosting Nothing + ,Posting False "b" missingamt "" RegularPosting Nothing + ] "")) + + ] diff --git a/Ledger/Types.hs b/Ledger/Types.hs new file mode 100644 --- /dev/null +++ b/Ledger/Types.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-| + +Most data types are defined here to avoid import cycles. +Here is an overview of the hledger data model: + +> Ledger -- hledger's ledger is a journal file plus cached/derived data +> Journal -- a representation of the journal file, containing.. +> [Transaction] -- ..journal transactions, which have date, status, code, description and.. +> [Posting] -- ..two or more account postings (account name and amount) +> Tree AccountName -- all account names as a tree +> Map AccountName Account -- a map from account name to account info (postings and balances) + +For more detailed documentation on each type, see the corresponding modules. + +Terminology has been in flux: + + - ledger 2 had entries containing transactions. + + - hledger 0.4 had Entrys containing RawTransactions, which were flattened to Transactions. + + - ledger 3 has transactions containing postings. + + - hledger 0.5 had LedgerTransactions containing Postings, which were flattened to Transactions. + + - hledger 0.8 has Transactions containing Postings, and no flattened type. + +-} + +module Ledger.Types +where +import Ledger.Utils +import qualified Data.Map as Map +import System.Time (ClockTime) +import Data.Typeable (Typeable) + + +type SmartDate = (String,String,String) + +data WhichDate = ActualDate | EffectiveDate deriving (Eq,Show) + +data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Show,Ord) + +data Interval = NoInterval | Daily | Weekly | Monthly | Quarterly | Yearly + deriving (Eq,Show,Ord) + +type AccountName = String + +data Side = L | R deriving (Eq,Show,Ord) + +data Commodity = Commodity { + symbol :: String, -- ^ the commodity's symbol + -- display preferences for amounts of this commodity + side :: Side, -- ^ should the symbol appear on the left or the right + spaced :: Bool, -- ^ should there be a space between symbol and quantity + comma :: Bool, -- ^ should thousands be comma-separated + precision :: Int -- ^ number of decimal places to display + } deriving (Eq,Show,Ord) + +data Amount = Amount { + commodity :: Commodity, + quantity :: Double, + price :: Maybe MixedAmount -- ^ unit price/conversion rate for this amount at posting time + } deriving (Eq) + +newtype MixedAmount = Mixed [Amount] deriving (Eq) + +data PostingType = RegularPosting | VirtualPosting | BalancedVirtualPosting + deriving (Eq,Show) + +data Posting = Posting { + pstatus :: Bool, + paccount :: AccountName, + pamount :: MixedAmount, + pcomment :: String, + ptype :: PostingType, + ptransaction :: Maybe Transaction -- ^ this posting's parent transaction (co-recursive types). + -- Tying this knot gets tedious, Maybe makes it easier/optional. + } deriving (Eq) + +data Transaction = Transaction { + tdate :: Day, + teffectivedate :: Maybe Day, + tstatus :: Bool, -- XXX tcleared ? + tcode :: String, + tdescription :: String, + tcomment :: String, + tpostings :: [Posting], + tpreceding_comment_lines :: String + } deriving (Eq) + +data ModifierTransaction = ModifierTransaction { + mtvalueexpr :: String, + mtpostings :: [Posting] + } deriving (Eq) + +data PeriodicTransaction = PeriodicTransaction { + ptperiodicexpr :: String, + ptpostings :: [Posting] + } deriving (Eq) + +data TimeLogCode = SetBalance | SetRequiredHours | In | Out | FinalOut deriving (Eq,Ord) + +data TimeLogEntry = TimeLogEntry { + tlcode :: TimeLogCode, + tldatetime :: LocalTime, + tlcomment :: String + } deriving (Eq,Ord) + +data HistoricalPrice = HistoricalPrice { + hdate :: Day, + hsymbol :: String, + hamount :: MixedAmount + } deriving (Eq) -- & Show (in Amount.hs) + +data Journal = Journal { + jmodifiertxns :: [ModifierTransaction], + jperiodictxns :: [PeriodicTransaction], + jtxns :: [Transaction], + open_timelog_entries :: [TimeLogEntry], + historical_prices :: [HistoricalPrice], + final_comment_lines :: String, + filepath :: FilePath, + filereadtime :: ClockTime, + jtext :: String + } deriving (Eq) + +data Account = Account { + aname :: AccountName, + apostings :: [Posting], -- ^ transactions in this account + abalance :: MixedAmount -- ^ sum of transactions in this account and subaccounts + } + +data Ledger = Ledger { + journal :: Journal, + accountnametree :: Tree AccountName, + accountmap :: Map.Map AccountName Account + } deriving Typeable + +-- | A generic, pure specification of how to filter transactions/postings. +-- This exists to keep app-specific options out of the hledger library. +data FilterSpec = FilterSpec { + datespan :: DateSpan -- ^ only include if in this date span + ,cleared :: Maybe Bool -- ^ only include if cleared\/uncleared\/don't care + ,real :: Bool -- ^ only include if real\/don't care + ,empty :: Bool -- ^ include if empty (ie amount is zero) + ,costbasis :: Bool -- ^ convert all amounts to cost basis + ,acctpats :: [String] -- ^ only include if matching these account patterns + ,descpats :: [String] -- ^ only include if matching these description patterns + ,whichdate :: WhichDate -- ^ which dates to use (actual or effective) + ,depth :: Maybe Int + } deriving (Show) + diff --git a/Ledger/Utils.hs b/Ledger/Utils.hs new file mode 100644 --- /dev/null +++ b/Ledger/Utils.hs @@ -0,0 +1,321 @@ +{-# LANGUAGE CPP #-} +{-| + +Provide standard imports and utilities which are useful everywhere, or +needed low in the module hierarchy. This is the bottom of the dependency graph. + +-} + +module Ledger.Utils ( +module Data.Char, +module Control.Monad, +module Data.List, +--module Data.Map, +module Data.Maybe, +module Data.Ord, +module Data.Tree, +module Data.Time.Clock, +module Data.Time.Calendar, +module Data.Time.LocalTime, +module Debug.Trace, +module Ledger.Utils, +module Text.Printf, +module Text.RegexPR, +module Test.HUnit, +) +where +import Data.Char +import Control.Exception +import Control.Monad +import Data.List +--import qualified Data.Map as Map +import Data.Maybe +import Data.Ord +import Data.Tree +import Data.Time.Clock +import Data.Time.Calendar +import Data.Time.LocalTime +import Debug.Trace +#if __GLASGOW_HASKELL__ <= 610 +import Prelude hiding (readFile,putStr,print) +import System.IO.UTF8 +#endif +import Test.HUnit +import Text.Printf +import Text.RegexPR +import Text.ParserCombinators.Parsec + + +-- strings + +lowercase = map toLower +uppercase = map toUpper + +strip = lstrip . rstrip +lstrip = dropws +rstrip = reverse . dropws . reverse +dropws = dropWhile (`elem` " \t") + +elideLeft width s = + if length s > width then ".." ++ reverse (take (width - 2) $ reverse s) else s + +elideRight width s = + if length s > width then take (width - 2) s ++ ".." else s + +underline :: String -> String +underline s = s' ++ replicate (length s) '-' ++ "\n" + where s' + | last s == '\n' = s + | otherwise = s ++ "\n" + +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 (padleft w) ls where w | null ls = 0 + | otherwise = maximum $ map length ls + padded = map (xpad . ypad) lss + +-- | Compose strings vertically and right-aligned. +vConcatRightAligned :: [String] -> String +vConcatRightAligned ss = intercalate "\n" $ map showfixedwidth ss + where + showfixedwidth = printf (printf "%%%ds" width) + width = maximum $ map length ss + +-- | Convert a multi-line string to a rectangular string top-padded to the specified height. +padtop :: Int -> String -> String +padtop h s = intercalate "\n" xpadded + where + ls = lines s + sh = length ls + sw | null ls = 0 + | otherwise = maximum $ map length ls + ypadded = replicate (difforzero h sh) "" ++ ls + xpadded = map (padleft sw) ypadded + +-- | Convert a multi-line string to a rectangular string bottom-padded to the specified height. +padbottom :: Int -> String -> String +padbottom h s = intercalate "\n" xpadded + where + ls = lines s + sh = length ls + sw | null ls = 0 + | otherwise = maximum $ map length ls + ypadded = ls ++ replicate (difforzero h sh) "" + xpadded = map (padleft sw) ypadded + +-- | Convert a multi-line string to a rectangular string left-padded to the specified width. +padleft :: Int -> String -> String +padleft w "" = concat $ replicate w " " +padleft w s = intercalate "\n" $ map (printf (printf "%%%ds" w)) $ lines s + +-- | Convert a multi-line string to a rectangular string right-padded to the specified width. +padright :: Int -> String -> String +padright w "" = concat $ replicate w " " +padright w s = intercalate "\n" $ map (printf (printf "%%-%ds" w)) $ lines s + +-- | Clip a multi-line string to the specified width and height from the top left. +cliptopleft :: Int -> Int -> String -> String +cliptopleft w h = intercalate "\n" . take h . map (take w) . lines + +-- | Clip and pad a multi-line string to fill the specified width and height. +fitto :: Int -> Int -> String -> String +fitto w h s = intercalate "\n" $ take h $ rows ++ repeat blankline + where + rows = map (fit w) $ lines s + fit w = take w . (++ repeat ' ') + blankline = replicate w ' ' + +-- math + +difforzero :: (Num a, Ord a) => a -> a -> a +difforzero a b = maximum [(a - b), 0] + +-- regexps + +containsRegex :: String -> String -> Bool +containsRegex r s = case matchRegexPR ("(?i)"++r) s of + Just _ -> True + _ -> False + + +-- lists + +splitAtElement :: Eq a => a -> [a] -> [[a]] +splitAtElement e l = + case dropWhile (e==) l of + [] -> [] + l' -> first : splitAtElement e rest + where + (first,rest) = break (e==) l' + +-- trees + +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 (containsRegex "[^ \\|]") . lines . drawTree . treemap show + +-- | show a compact ascii representation of a forest +showforest :: Show a => Forest a -> String +showforest = concatMap showtree + +-- debugging + +-- | trace (print on stdout at runtime) a showable expression +-- (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 newline and a label prepended +ltrace :: Show a => String -> a -> a +ltrace l a = trace (l ++ ": " ++ show a) a + +-- | trace an expression using a custom show function +tracewith f e = trace (f e) e + +-- parsing + +parsewith :: Parser a -> String -> Either ParseError a +parsewith p = parse p "" + +parseWithCtx :: b -> GenParser Char b a -> String -> Either ParseError a +parseWithCtx ctx p = runParser p ctx "" + +fromparse :: Either ParseError a -> a +fromparse = either parseerror id + +parseerror e = error $ showParseError e + +showParseError e = "parse error at " ++ show e + +showDateParseError e = printf "date parse error (%s)" (intercalate ", " $ tail $ lines $ show e) + +nonspace :: GenParser Char st Char +nonspace = satisfy (not . isSpace) + +spacenonewline :: GenParser Char st Char +spacenonewline = satisfy (`elem` " \v\f\t") + +restofline :: GenParser Char st String +restofline = anyChar `manyTill` newline + +-- time + +getCurrentLocalTime :: IO LocalTime +getCurrentLocalTime = do + t <- getCurrentTime + tz <- getCurrentTimeZone + return $ utcToLocalTime tz t + +-- testing + +-- | Get a Test's label, or the empty string. +tname :: Test -> String +tname (TestLabel n _) = n +tname _ = "" + +-- | Flatten a Test containing TestLists into a list of single tests. +tflatten :: Test -> [Test] +tflatten (TestLabel _ t@(TestList _)) = tflatten t +tflatten (TestList ts) = concatMap tflatten ts +tflatten t = [t] + +-- | Filter TestLists in a Test, recursively, preserving the structure. +tfilter :: (Test -> Bool) -> Test -> Test +tfilter p (TestLabel l ts) = TestLabel l (tfilter p ts) +tfilter p (TestList ts) = TestList $ filter (any p . tflatten) $ map (tfilter p) ts +tfilter _ 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 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 + +strictReadFile :: FilePath -> IO String +strictReadFile f = readFile f >>= \s -> Control.Exception.evaluate (length s) >> return s diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple + +main = defaultMain diff --git a/hledger-lib.cabal b/hledger-lib.cabal new file mode 100644 --- /dev/null +++ b/hledger-lib.cabal @@ -0,0 +1,73 @@ +name: hledger-lib +version: 0.9 +category: Finance +synopsis: Core types and utilities for working with hledger (or c++ ledger) data. +description: + This is the reusable core of the hledger financial app; use it to + build hledger and c++-ledger compatible finance tools. + +license: GPL +license-file: LICENSE +author: Simon Michael +maintainer: Simon Michael +homepage: http://hledger.org +bug-reports: http://code.google.com/p/hledger/issues +stability: experimental +tested-with: GHC==6.10 +cabal-version: >= 1.2 +build-type: Simple +-- data-dir: +-- data-files: +-- extra-tmp-files: +-- extra-source-files: +-- README +-- sample.ledger +-- sample.timelog + +library + exposed-modules: + Ledger + Ledger.Account + Ledger.AccountName + Ledger.Amount + Ledger.Commodity + Ledger.Dates + Ledger.IO + Ledger.Transaction + Ledger.Journal + Ledger.Ledger + Ledger.Posting + Ledger.Parse + Ledger.TimeLog + Ledger.Types + Ledger.Utils + Build-Depends: + base >= 3 && < 5 + ,containers + ,directory + ,filepath + ,mtl + ,old-locale + ,old-time + ,parsec + ,regexpr >= 0.5.1 + ,time + ,utf8-string >= 0.3 + ,HUnit + + -- should set patchlevel here as in Makefile + cpp-options: -DPATCHLEVEL=0 + +-- source-repository head +-- type: darcs +-- location: http://joyful.com/repos/hledger +-- disabled for now due to: +-- The 'source-repository' section is new in Cabal-1.6. Unfortunately it messes +-- up the parser in earlier Cabal versions so you need to specify 'cabal-version: +-- >= 1.6'. + +-- 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