hledger-lib (empty) → 0.9
raw patch · 18 files changed
+4090/−0 lines, 18 filesdep +HUnitdep +basedep +containerssetup-changed
Dependencies added: HUnit, base, containers, directory, filepath, mtl, old-locale, old-time, parsec, regexpr, time, utf8-string
Files
- LICENSE +674/−0
- Ledger.hs +58/−0
- Ledger/Account.hs +27/−0
- Ledger/AccountName.hs +171/−0
- Ledger/Amount.hs +340/−0
- Ledger/Commodity.hs +39/−0
- Ledger/Dates.hs +464/−0
- Ledger/IO.hs +99/−0
- Ledger/Journal.hs +321/−0
- Ledger/Ledger.hs +180/−0
- Ledger/Parse.hs +732/−0
- Ledger/Posting.hs +94/−0
- Ledger/TimeLog.hs +90/−0
- Ledger/Transaction.hs +250/−0
- Ledger/Types.hs +153/−0
- Ledger/Utils.hs +321/−0
- Setup.hs +4/−0
- hledger-lib.cabal +73/−0
+ LICENSE view
@@ -0,0 +1,674 @@+ GNU GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++ Preamble++ The GNU General Public License is a free, copyleft license for+software and other kinds of works.++ The licenses for most software and other practical works are designed+to take away your freedom to share and change the works. By contrast,+the GNU General Public License is intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users. We, the Free Software Foundation, use the+GNU General Public License for most of our software; it applies also to+any other work released this way by its authors. You can apply it to+your programs, too.++ When we speak of free software, we are referring to freedom, not+price. Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), that you receive source code or can get it if you+want it, that you can change the software or use pieces of it in new+free programs, and that you know you can do these things.++ To protect your rights, we need to prevent others from denying you+these rights or asking you to surrender the rights. Therefore, you have+certain responsibilities if you distribute copies of the software, or if+you modify it: responsibilities to respect the freedom of others.++ For example, if you distribute copies of such a program, whether+gratis or for a fee, you must pass on to the recipients the same+freedoms that you received. You must make sure that they, too, receive+or can get the source code. And you must show them these terms so they+know their rights.++ Developers that use the GNU GPL protect your rights with two steps:+(1) assert copyright on the software, and (2) offer you this License+giving you legal permission to copy, distribute and/or modify it.++ For the developers' and authors' protection, the GPL clearly explains+that there is no warranty for this free software. For both users' and+authors' sake, the GPL requires that modified versions be marked as+changed, so that their problems will not be attributed erroneously to+authors of previous versions.++ Some devices are designed to deny users access to install or run+modified versions of the software inside them, although the manufacturer+can do so. This is fundamentally incompatible with the aim of+protecting users' freedom to change the software. The systematic+pattern of such abuse occurs in the area of products for individuals to+use, which is precisely where it is most unacceptable. Therefore, we+have designed this version of the GPL to prohibit the practice for those+products. If such problems arise substantially in other domains, we+stand ready to extend this provision to those domains in future versions+of the GPL, as needed to protect the freedom of users.++ Finally, every program is threatened constantly by software patents.+States should not allow patents to restrict development and use of+software on general-purpose computers, but in those that do, we wish to+avoid the special danger that patents applied to a free program could+make it effectively proprietary. To prevent this, the GPL assures that+patents cannot be used to render the program non-free.++ The precise terms and conditions for copying, distribution and+modification follow.++ TERMS AND CONDITIONS++ 0. Definitions.++ "This License" refers to version 3 of the GNU General Public License.++ "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++ "The Program" refers to any copyrightable work licensed under this+License. Each licensee is addressed as "you". "Licensees" and+"recipients" may be individuals or organizations.++ To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy. The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++ A "covered work" means either the unmodified Program or a work based+on the Program.++ To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy. Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++ To "convey" a work means any kind of propagation that enables other+parties to make or receive copies. Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++ An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License. If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++ 1. Source Code.++ The "source code" for a work means the preferred form of the work+for making modifications to it. "Object code" means any non-source+form of a work.++ A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++ The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form. A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++ The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities. However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work. For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++ The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++ The Corresponding Source for a work in source code form is that+same work.++ 2. Basic Permissions.++ All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met. This License explicitly affirms your unlimited+permission to run the unmodified Program. The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work. This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++ You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force. You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright. Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++ Conveying under any other circumstances is permitted solely under+the conditions stated below. Sublicensing is not allowed; section 10+makes it unnecessary.++ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.++ No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++ When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++ 4. Conveying Verbatim Copies.++ You may convey verbatim copies of the Program's source code as you+receive it, in any medium, provided that you conspicuously and+appropriately publish on each copy an appropriate copyright notice;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++ You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++ 5. Conveying Modified Source Versions.++ You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++ a) The work must carry prominent notices stating that you modified+ it, and giving a relevant date.++ b) The work must carry prominent notices stating that it is+ released under this License and any conditions added under section+ 7. This requirement modifies the requirement in section 4 to+ "keep intact all notices".++ c) You must license the entire work, as a whole, under this+ License to anyone who comes into possession of a copy. This+ License will therefore apply, along with any applicable section 7+ additional terms, to the whole of the work, and all its parts,+ regardless of how they are packaged. This License gives no+ permission to license the work in any other way, but it does not+ invalidate such permission if you have separately received it.++ d) If the work has interactive user interfaces, each must display+ Appropriate Legal Notices; however, if the Program has interactive+ interfaces that do not display Appropriate Legal Notices, your+ work need not make them do so.++ A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit. Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++ 6. Conveying Non-Source Forms.++ You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++ a) Convey the object code in, or embodied in, a physical product+ (including a physical distribution medium), accompanied by the+ Corresponding Source fixed on a durable physical medium+ customarily used for software interchange.++ b) Convey the object code in, or embodied in, a physical product+ (including a physical distribution medium), accompanied by a+ written offer, valid for at least three years and valid for as+ long as you offer spare parts or customer support for that product+ model, to give anyone who possesses the object code either (1) a+ copy of the Corresponding Source for all the software in the+ product that is covered by this License, on a durable physical+ medium customarily used for software interchange, for a price no+ more than your reasonable cost of physically performing this+ conveying of source, or (2) access to copy the+ Corresponding Source from a network server at no charge.++ c) Convey individual copies of the object code with a copy of the+ written offer to provide the Corresponding Source. This+ alternative is allowed only occasionally and noncommercially, and+ only if you received the object code with such an offer, in accord+ with subsection 6b.++ d) Convey the object code by offering access from a designated+ place (gratis or for a charge), and offer equivalent access to the+ Corresponding Source in the same way through the same place at no+ further charge. You need not require recipients to copy the+ Corresponding Source along with the object code. If the place to+ copy the object code is a network server, the Corresponding Source+ may be on a different server (operated by you or a third party)+ that supports equivalent copying facilities, provided you maintain+ clear directions next to the object code saying where to find the+ Corresponding Source. Regardless of what server hosts the+ Corresponding Source, you remain obligated to ensure that it is+ available for as long as needed to satisfy these requirements.++ e) Convey the object code using peer-to-peer transmission, provided+ you inform other peers where the object code and Corresponding+ Source of the work are being offered to the general public at no+ charge under subsection 6d.++ A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++ A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling. In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage. For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product. A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++ "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source. The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++ If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information. But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++ The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed. Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++ Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++ 7. Additional Terms.++ "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law. If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++ When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it. (Additional permissions may be written to require their own+removal in certain cases when you modify the work.) You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++ Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++ a) Disclaiming warranty or limiting liability differently from the+ terms of sections 15 and 16 of this License; or++ b) Requiring preservation of specified reasonable legal notices or+ author attributions in that material or in the Appropriate Legal+ Notices displayed by works containing it; or++ c) Prohibiting misrepresentation of the origin of that material, or+ requiring that modified versions of such material be marked in+ reasonable ways as different from the original version; or++ d) Limiting the use for publicity purposes of names of licensors or+ authors of the material; or++ e) Declining to grant rights under trademark law for use of some+ trade names, trademarks, or service marks; or++ f) Requiring indemnification of licensors and authors of that+ material by anyone who conveys the material (or modified versions of+ it) with contractual assumptions of liability to the recipient, for+ any liability that these contractual assumptions directly impose on+ those licensors and authors.++ All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10. If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term. If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++ If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++ Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++ 8. Termination.++ You may not propagate or modify a covered work except as expressly+provided under this License. Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++ However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++ Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++ Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License. If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++ 9. Acceptance Not Required for Having Copies.++ You are not required to accept this License in order to receive or+run a copy of the Program. Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance. However,+nothing other than this License grants you permission to propagate or+modify any covered work. These actions infringe copyright if you do+not accept this License. Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++ 10. Automatic Licensing of Downstream Recipients.++ Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License. You are not responsible+for enforcing compliance by third parties with this License.++ An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations. If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++ You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License. For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++ 11. Patents.++ A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based. The+work thus licensed is called the contributor's "contributor version".++ A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version. For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++ Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++ In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement). To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++ If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients. "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++ If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++ A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License. You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++ Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++ 12. No Surrender of Others' Freedom.++ If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License. If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all. For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++ 13. Use with the GNU Affero General Public License.++ Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU Affero General Public License into a single+combined work, and to convey the resulting work. The terms of this+License will continue to apply to the part which is the covered work,+but the special requirements of the GNU Affero General Public License,+section 13, concerning interaction through a network will apply to the+combination as such.++ 14. Revised Versions of this License.++ The Free Software Foundation may publish revised and/or new versions of+the GNU General Public License from time to time. Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++ Each version is given a distinguishing version number. If the+Program specifies that a certain numbered version of the GNU General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation. If the Program does not specify a version number of the+GNU General Public License, you may choose any version ever published+by the Free Software Foundation.++ If the Program specifies that a proxy can decide which future+versions of the GNU General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++ Later license versions may give you additional or different+permissions. However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++ 15. Disclaimer of Warranty.++ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++ 16. Limitation of Liability.++ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++ 17. Interpretation of Sections 15 and 16.++ If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++ END OF TERMS AND CONDITIONS++ How to Apply These Terms to Your New Programs++ If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++ To do so, attach the following notices to the program. It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++ <one line to give the program's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ This program is free software: you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation, either version 3 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program. If not, see <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++ If the program does terminal interaction, make it output a short+notice like this when it starts in an interactive mode:++ <program> Copyright (C) <year> <name of author>+ This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+ This is free software, and you are welcome to redistribute it+ under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License. Of course, your program's commands+might be different; for a GUI interface, you would use an "about box".++ You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU GPL, see+<http://www.gnu.org/licenses/>.++ The GNU General Public License does not permit incorporating your program+into proprietary programs. If your program is a subroutine library, you+may consider it more useful to permit linking proprietary applications with+the library. If this is what you want to do, use the GNU Lesser General+Public License instead of this License. But first, please read+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+ Ledger.hs view
@@ -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+ ]
+ Ledger/Account.hs view
@@ -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+
+ Ledger/AccountName.hs view
@@ -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+
+ Ledger/Amount.hs view
@@ -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]+++ ]
+ Ledger/Commodity.hs view
@@ -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+
+ Ledger/Dates.hs view
@@ -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"]++ ]
+ Ledger/IO.hs view
@@ -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+
+ Ledger/Journal.hs view
@@ -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]
+ Ledger/Ledger.hs view
@@ -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
+ Ledger/Parse.hs view
@@ -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] ""++
+ Ledger/Posting.hs view
@@ -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+
+ Ledger/TimeLog.hs view
@@ -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+ ]
+ Ledger/Transaction.hs view
@@ -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+ ] ""))++ ]
+ Ledger/Types.hs view
@@ -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)+
+ Ledger/Utils.hs view
@@ -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
+ Setup.hs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runhaskell+import Distribution.Simple++main = defaultMain
+ hledger-lib.cabal view
@@ -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 <simon@joyful.com>+maintainer: Simon Michael <simon@joyful.com>+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