buchhaltung (empty) → 0.0.1
raw patch · 26 files changed
+4857/−0 lines, 26 filesdep +Decimaldep +ListLikedep +MissingHbuild-type:Customsetup-changed
Dependencies added: Decimal, ListLike, MissingH, aeson, ansi-wl-pprint, array, async, base, boxes, bytestring, cassava, containers, data-default, deepseq, directory, edit-distance, file-embed, filepath, formatting, hashable, haskeline, hint, hledger, hledger-lib, lens, lifted-base, megaparsec, monad-control, mtl, optparse-applicative, parsec, process, regex-compat, regex-tdfa, regex-tdfa-text, safe, semigroups, split, strict, temporary, text, time, transformers, unordered-containers, vector, yaml
Files
- LICENSE +21/−0
- README.md +263/−0
- Setup.hs +14/−0
- add.md +82/−0
- add_multi_user.md +131/−0
- buchhaltung.cabal +108/−0
- buchhaltung_autocomplete.bash +15/−0
- buchhaltung_autocomplete.zsh +16/−0
- config.yml +55/−0
- match.md +36/−0
- src/Buchhaltung/AQBanking.hs +138/−0
- src/Buchhaltung/Add.hs +896/−0
- src/Buchhaltung/Ask.hs +99/−0
- src/Buchhaltung/Commandline.hs +116/−0
- src/Buchhaltung/Common.hs +407/−0
- src/Buchhaltung/Import.hs +132/−0
- src/Buchhaltung/Importers.hs +692/−0
- src/Buchhaltung/Match.hs +211/−0
- src/Buchhaltung/OptionParsers.hs +162/−0
- src/Buchhaltung/Types.hs +476/−0
- src/Buchhaltung/Uniques.hs +175/−0
- src/Buchhaltung/Utils.hs +94/−0
- src/Buchhaltung/ZipEdit2.hs +429/−0
- src/Buchhaltung/Zipper.hs +74/−0
- src/main.hs +4/−0
- stack.yaml +11/−0
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2016 Johannes Gerer++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,263 @@+# Buchhaltung [](https://travis-ci.org/johannesgerer/buchhaltung) [](https://hackage.haskell.org/package/buchhaltung)++> What advantages does he derive from the system of book-keeping by double entry! It is among the finest inventions of the human mind; every prudent master of a house should introduce it into his economy.+> -- Johann Wolfgang von Goethe++*Buchhaltung* (['buːχˌhaltʊŋ], German *book keeping*), written in Haskell, helps you keep track of your finances on the commandline with minimal effort. It provides tools that help you in creating a complete ledger of all your bank and savings accounts', credit cards', and other transactions, in a text-based ledger format, that is readable by the [ledger CLI tool](http://www.ledger-cli.org/) and its many [derivatives](http://plaintextaccounting.org/).++* Fetch your bank transaction directly via FinTS/HBCI/OFXDirectConnect+* Import transactions from PayPal (can be customized to other formats)+* Semi-automatically match transactions to accounts using Bayesian classification+* Semi-automatic transaction entry with meaningful suggestions in keyboard-based speed mode+ * It is couples/room-mates aware: Create several transaction simultaniuously (see [Multi-user add](#multi-user-add))++## Status & aim++I am actively and successfully using this software since 2010 and my ledger now contains more than 12,000 transactions accurately and continuously tracking the finances of my spouse and me including four checking and two savings accounts, one credit card, two paypal accounts, two cash wallets in EUR, bitcoin trading (both physical and on exchanges) and other currencies like USD, GPB used on trips.++The software is in alpha phase and I am looking for early adopters and their use cases. The aim of this stage is to agree about the functionality and customizability and produce a first shipable version, that can be used without tinkering with the source.++Right now, I am using it on Linux but it should also run wherever GHC runs.++# Installation++## Prerequisites++* [Haskell Stack](https://haskell-lang.org/get-started), more specifically the [Glasgow Haskell Compiler](https://www.haskell.org/) and [Stack](https://docs.haskellstack.org/en/stable/README/)++ Required to **compile** the software.+ +* [AqBanking Command Line Tool](http://www2.aquamaniac.de/sites/aqbanking/index.php) (optional)++ This is required for **direct retrieval of bank transactions** via FinTS/HBCI/EBICS (Germany) or OFXDirectConnect (USA, Canada, UK). Packages available e.g. on Ubuntu (aqbanking-tools) and ArchLinux (aqbanking). (AqBanking is also the used by [GnuCash](http://wiki.gnucash.org/wiki/AqBanking) for this purpose.)++* [dbacl](http://dbacl.sourceforge.net/) (optional, needed to run [`match`](#match-accounts))++ Bayesian classifier used to **match transaction to accounts**. Packages available e.g. on Ubuntu and ArchLinux ([AUR](https://aur.archlinux.org/packages/dbacl/)).++* [ledger CLI tool](http://www.ledger-cli.org/) or a compatible [derivative](http://plaintextaccounting.org/) (optional)++ ... to **query the ledger, create balance and report statements**, [web interface](http://hledger.org/hledger-web.html), etc.++## Download, compile & install++```shell+# download+git clone https://github.com/johannesgerer/buchhaltung.git+cd buchhaltung+++# compile and install (usually in ~/.local/bin)+stack install++```++## Configure++1. Create a folder that will hold all your config and possibly ledger files:+ + ```shell+ mkdir ~/.buchhaltung+ cp /path/to/buchhaltung/config.yml ~/.buchhaltung/config.yml+ ```+ + If you want a folder under a different location, either create a symlink or set the `BUCHHALTUNG` environment variable to that location.++2. Edit the `config.yml`.++3. Make sure the configured ledger files exist.++# Getting help++* The `config.yml` file provides excessive comments.+* This readme documents most functionality.+* Every command and subcommand shows a help message when invoked with `-h`.+* Read the haddock documentation and source code on [Hackage](https://hackage.haskell.org/package/hashtables).+* Open an issue.+* Write an email.++# Usage++## First usage / clean++To initialize AqBanking after you edited the config file, you need to run:++```shell+buchhaltung setup+```++To clean everythink aqbanking related remove the configured `aqBanking.configDir` and rerun the `setup` command.++### Manual AqBanking setup++Currently only the `PinTan` method is supportend (pull requests welcome). For other methods or if the AqBanking setup fails due to other reasons, you can configure AqBanking manually into the configured `aqBanking.configDir` (see for help [here](https://www.aquamaniac.de/sites/download/download.php?package=09&release=09&file=01&dummy=aqbanking4-handbook-20091231.pdf) or [here](https://wiki.gnucash.org/wiki/AqBanking), usually via `aqhbci-tool4 -C <aqBanking.configDir>`).++## Importing transactions++There various ways (including from PayPal CSV files) to import transactions into your configured `ledgers.imported` file. They are presented in the folling, but consult++```shell+buchhaltung import -h+```++and the `-h` calls to its subcommands to see the currently available functionality.++The accounts of the imported transactions will be taken from the configured `bankAccounts` and the offsetting balaence will be posted to an account named `TODO`, and will be replaced by [`match`](#match-accounts).++The original source information will be included in the second posting's comment and used for learning the account mappings and to find and handle duplicates.++### AqBanking++```shell+buchhaltung update+```++This command fetches and imports all available transactions from all configured AqBanking connections.+++### Resolve duplicates++Banks often minimally change the way they report transactions which leads to unwanted duplicates.++When importing, *Buchhaltung* will identify duplicates based on `([(Commodity,Quantity)], AccountName, Day)` and interactively resolve them by showing the user what fields have changed. If there are several candidates, it sorts the candidates according to similarity using `levenshteinDistance` from [edit-distance](https://hackage.haskell.org/package/edit-distance-0.2.1.3). (See [`Buchhaltung.Uniques.addNew`](https://github.com/johannesgerer/buchhaltung/blob/master/src/Buchhaltung/Uniques.hs#L27))++## Match accounts++```shell+buchhaltung match+```++This command asks the user for the offsetting accounts of imported transactions, or more specifically, transaction whose second posting's account begins with `TODO`. ++Have a look at the example output [here](match.md).++The significantly speed up this process, it learns the account mapping from existing transactions in the configured `ledgers.imported` file using the original source of the imported tansaction. ++See [this](#input-and-tab-completion) information about the account input field.+++### Best practices+ +The Bayesian classifier can only work if similar transactions are always matched with the same account.++Consider frequent credit card payments to Starbucks:++* Match them with `Expenses:Food:Starbucks` if you know that these should always be booked to that account.++* Match them with `Accounts receivable:Starbucks` and [manually enter](#enter-transactions) your paper receipts if ++ * you want to make sure they charge you the correct amounts.+ + * you sometimes order for friends and get reimbursed later.+ + * ...++## Enter transactions++```shell+buchhaltung add+```++This command opens a transaction editor. [Here](add.md) is an example of the output of this command.++The amount of manual typing is kept to a minimum by two clever suggestion mechanisms and TAB completion.++### Input and TAB completion++All input fields save their history in the current directory. It can be browsed using up and down arrow keys.++The account input fields support TAB completion. To make this even more useful, the account hierarchy is read in reverse order. For example `Expenses:Food` has to be entered as `Food:Expenses`.++### Suggested transactions++After the amount is entered, the user can select a transaction whose title, date, amount and second posting's account will used to prefill an offsetting transaction. Suggestions will consist of all transactions++* whose second posting has not been cleared (i.e. marked with an asterisk in front of the account name, and+* whose first posting's amount has the absolute value as the entered amount+* whose first posting's account is contained in the configured `bankAccounts` and does not match any of regexes in `ignoredAccountsOnAdd`.++### Suggested accounts++Once the first posting's account has been entered, the editor suggests accounts for the second posting based on the frequecy of the resulting transaction's accounts in the configured `ledgers.addedByThisUser` file.++### Assertions \& assignments++Amounts can be entered with [assertions](http://hledger.org/manual.html#balance-assertions) or can be [assigned](http://hledger.org/manual.html#balance-assignments). ++### Default currency++In order to be able to enter naked amounts and have the currency added automatically, add a [default currency](http://hledger.org/manual.html#default-commodity) to the configured `addedByThisUser` ledger file. Example:++```+D 1,000.000 EUR+```+++### Multi-user add++```shell+buchhaltung add -w alice+```++If there is more than one user configured — possibly each with their own ledger, they can be included/activated via the commandline argument `-w`. This enables you to enter a transaction where postings belong to different users. When done, a transaction for each user will be generated containing their respective postings and a balancing posting to an account prefixed with the configured `accountPrefixOthers`.++Example taken from the [output](add_multi_user.md) of the above command:++```shell+#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++2016/12/19 Dinner++ Account | Amount | Assertion+-------------------------+----------+-----------+----------+0,jo Wallet:Assets | $ -100.0 | |+1,jo Food:Expenses | $ 50 | |+2,alice Food:Expenses | $ 50 | |+-------------------------+----------+-----------+----------+Open Balance | 0 |+```++generates the following transactions++```shell+####### jo: Balanced Transaction #######++2016/12/19 Dinner ; Entered on "2016-12-19T19:01:00Z" by 'buchhaltung' user jo+ Wallet:Assets $ -100.0+ Food:Expenses $ 50+ Accounts receivable:Friends:alice:jo $ 50++++####### alice: Balanced Transaction #######++2016/12/19 Dinner ; Entered on "2016-12-19T19:01:00Z" by 'buchhaltung' user jo+ Accounts receivable:Friends:jo:jo $ -50+ Food:Expenses $ 50+```++## Getting results++### Get current AqBanking account balances++```shell+buchhaltung lb+```++### Call `ledger` or `hledger`++```shell+buchhaltung ledger++buchhaltung hledger+```++This calls the respective program with the `LEDGER` environment variable set to the configured `mainLedger` or `mainHledger`.++### Commit the changes++```shell+buchhaltung commit -a -m'checking account ok'+```++this commits all changes to the git repository that contains the `mainLedger` file. The commit message will also contain the output of `buchhaltung lb` and `buchhaltung ledger balance --end tomorrow`.
+ Setup.hs view
@@ -0,0 +1,14 @@+import Distribution.Simple+import Distribution.Simple.Setup+import Distribution.Simple.Haddock+main = do+ defaultMainWithHooks simpleUserHooks{+ haddockHook = \p l h flags -> haddockHook simpleUserHooks p l h flags{+ haddockHoogle = Flag True,+ haddockHtml = Flag True,+ haddockProgramArgs = [("-q",["aliased"])], -- does not seam to do anything+ haddockExecutables = Flag True,+ haddockHscolour = Flag True+ }+ }+
+ add.md view
@@ -0,0 +1,82 @@+```+(Reading journal from+"~/.buchhaltung/jo/import.ledger"+"~/.buchhaltung/jo/entered_by_jo.ledger")+...++Hi jo!++Use readline keys to edit, use tab key to complete account names.++A code (in parentheses) may be entered following transaction dates.++A comment may be entered following descriptions or amounts.++3378 Transactions found++Starting new transaction...+Enter amount (zero for any transaction) [0]: 22.94+1)+2015/01/19 DANKE, IHR LIDL LASTSCHRIFT/BELAST.EC 60128709 170115204807OC1Ref. 1CA15019A2006931/20702 ; generated: by Common.fillTxn 2015-03-31 03:29:48.644423 CEST+ Assets:Accounts:BankA:Checking -22.940 EUR+ Accounts payable:Lidl 22.940 EUR ; HBCI: "";"234789183";"234789183";"";"";"2015/01/19";"2015/01/19";"-22.94";"EUR";"Johannes Gerer";"DANKE, IHR LIDL";"";"LASTSCHRIFT/BELAST.EC 60128709 170115204807OC1Ref. 1CA15019A2006931/20702";"";"";"";"";"";"";"";"";"";"";"";"";"";"";"";"";"";"";""+++{number}: use one of the above 1 transactions+'m': enter transaction manually+'r': enter new amount to find existing transations+1++#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++2015/01/19 DANKE, IHR LIDL LASTSCHRIFT/BELAST.EC 60128709 170115204807OC1Ref. 1CA15019A2006931/20702++ Account | Amount | Assertion+----------------------------------------------+-------------+-----------+----------+0,jo Accounts payable:Lidl | -22.940 EUR | |+1,jo Expenses:Food | | | 129+2,jo -> Account receivable:Friends:Marc | | | 95+3,jo Assets:Food storage | | | 5+4,jo Expenses:Household | | | 1+----------------------------------------------+-------------+-----------+----------+Open Balance | 22.940 EUR |++[r]est [j]next [u]ser [+]add [t]itle [?]Help [s]ave [p]%+[h]alf [k]prev [n/N]ew [e]dit [d]ate [x]remove [Q]discard [v]AT+ [m]iss [c]lear+your action: r+++#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++2015/01/19 DANKE, IHR LIDL LASTSCHRIFT/BELAST.EC 60128709 170115204807OC1Ref. 1CA15019A2006931/20702++ Account | Amount | Assertion | Frequency+----------------------------------------------+-------------+-----------+----------+0,jo Accounts payable:Lidl | -22.940 EUR | |+1,jo Expenses:Food | 22.94 EUR | | 129+2,jo -> Account receivable:Friends:Marc | | | 95+3,jo Assets:Food storage | | | 5+4,jo Expenses:Household | | | 1+----------------------------------------------+-------------+-----------+----------+Open Balance | 0 |++[r]est [j]next [u]ser [+]add [t]itle [?]Help [s]ave [p]%+[h]alf [k]prev [n/N]ew [e]dit [d]ate [x]remove [Q]discard [v]AT+ [m]iss [c]lear+your action: s++####### jo: Balanced Transaction #######++2015/01/19 DANKE, IHR LIDL LASTSCHRIFT/BELAST.EC 60128709 170115204807OC1Ref. 1CA15019A2006931/20702 ; Entered on "2016-12-20T16:57:00Z" by 'buchhaltung' user jo+ Accounts payable:Lidl -22.940 EUR+ Expenses:Food 22.94 EUR++++Save? [y/N] y+New transaction created for 'jo'++1 Transactions were changed++```
+ add_multi_user.md view
@@ -0,0 +1,131 @@+```shell+$ buchhaltung add -w alice+(Reading journal from+"~/.buchhaltung/jo/import.ledger"+"~/.buchhaltung/jo/entered_by_jo.ledger")+...++Hi jo!++Use readline keys to edit, use tab key to complete account names.++A code (in parentheses) may be entered following transaction dates.++A comment may be entered following descriptions or amounts.++3380 Transactions found++Starting new transaction...+Enter amount (zero for any transaction) [0]: $ 100+Date [2016-12-19]:+Title: Dinner+Enter source account: Assets:Wallet++#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++2016/12/19 Dinner++ Account | Amount | Assertion+----------------------+----------+-----------+----------+0,jo -> Wallet:Assets | $ -100.0 | |+----------------------+----------+-----------+----------+Open Balance | $ 100.0 |++[r]est [j]next [u]ser [+]add [t]itle [?]Help [s]ave [p]%+[h]alf [k]prev [n/N]ew [e]dit [d]ate [x]remove [Q]discard [v]AT+ [m]iss [c]lear+your action: n++Account [Assets:Wallet]: Expenses:Food++#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++2016/12/19 Dinner++ Account | Amount | Assertion+----------------------+----------+-----------+----------+0,jo Wallet:Assets | $ -100.0 | |+1,jo -> Food:Expenses | | |+----------------------+----------+-----------+----------+Open Balance | $ 100.0 |++[r]est [j]next [u]ser [+]add [t]itle [?]Help [s]ave [p]%+[h]alf [k]prev [n/N]ew [e]dit [d]ate [x]remove [Q]discard [v]AT+ [m]iss [c]lear+your action: h+++#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++2016/12/19 Dinner++ Account | Amount | Assertion+----------------------+----------+-----------+----------+0,jo Wallet:Assets | $ -100.0 | |+1,jo -> Food:Expenses | $ 50 | |+----------------------+----------+-----------+----------+Open Balance | $ 50.0 |++[r]est [j]next [u]ser [+]add [t]itle [?]Help [s]ave [p]%+[h]alf [k]prev [n/N]ew [e]dit [d]ate [x]remove [Q]discard [v]AT+ [m]iss [c]lear+your action: N++Account [Expenses:Food]:++#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++2016/12/19 Dinner++ Account | Amount | Assertion+-------------------------+----------+-----------+----------+0,jo Wallet:Assets | $ -100.0 | |+1,jo Food:Expenses | $ 50 | |+2,alice -> Food:Expenses | | |+-------------------------+----------+-----------+----------+Open Balance | $ 50.0 |++[r]est [j]next [u]ser [+]add [t]itle [?]Help [s]ave [p]%+[h]alf [k]prev [n/N]ew [e]dit [d]ate [x]remove [Q]discard [v]AT+ [m]iss [c]lear+your action: r+++#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++2016/12/19 Dinner++ Account | Amount | Assertion+-------------------------+----------+-----------+----------+0,jo Wallet:Assets | $ -100.0 | |+1,jo Food:Expenses | $ 50 | |+2,alice -> Food:Expenses | $ 50 | |+-------------------------+----------+-----------+----------+Open Balance | 0 |++[r]est [j]next [u]ser [+]add [t]itle [?]Help [s]ave [p]%+[h]alf [k]prev [n/N]ew [e]dit [d]ate [x]remove [Q]discard [v]AT+ [m]iss [c]lear+your action: s++####### jo: Balanced Transaction #######++2016/12/19 Dinner ; Entered on "2016-12-19T19:01:00Z" by 'buchhaltung' user jo+ Wallet:Assets $ -100.0+ Food:Expenses $ 50+ Accounts receivable:Friends:alice:jo $ 50++++####### alice: Balanced Transaction #######++2016/12/19 Dinner ; Entered on "2016-12-19T19:01:00Z" by 'buchhaltung' user jo+ Accounts receivable:Friends:jo:jo $ -50+ Food:Expenses $ 50++++Save? [y/N] y+New transaction created for 'jo'+New transaction created for 'alice'+```
+ buchhaltung.cabal view
@@ -0,0 +1,108 @@+name: buchhaltung+version: 0.0.1+Bug-Reports: http://github.com/johannesgerer/buchhaltung/issues+License: MIT+License-file: LICENSE+Author: Johannes Gerer+Maintainer: Johannes Gerer <oss@johannesgerer.com>+Homepage: http://johannesgerer.com/buchhaltung+Stability: Experimental+category: Finance+synopsis: Automates most of your plain text accounting data entry in ledger format.+description:+ ATTENTION Use `stack build` as this package requires a developement version of `hledger`!++ Automatic import and deduplication (from CSV\/FinTS\/HBCI\/OFX), bayesian account matching, and efficient manual entry of <http://plaintextaccounting.org/ ledger> transactions.++ .+ See <https://github.com/johannesgerer/buchhaltung Readme> on Github.++tested-with: GHC == 7.10.1+cabal-version: >= 1.10+build-type: Custom++Extra-source-files:+ README.md+ add.md+ add_multi_user.md+ match.md+ stack.yaml+ config.yml+ buchhaltung_autocomplete.bash+ buchhaltung_autocomplete.zsh++Custom-setup+ setup-depends: base >= 4.0.0.0 && < 5, Cabal+++executable buchhaltung+ Hs-Source-Dirs: src+ main-is: main.hs+ other-modules: Buchhaltung.Add+ Buchhaltung.AQBanking+ Buchhaltung.Ask+ Buchhaltung.Common+ Buchhaltung.Import+ Buchhaltung.Importers+ Buchhaltung.Match+ Buchhaltung.Commandline+ Buchhaltung.OptionParsers+ Buchhaltung.Types+ Buchhaltung.Uniques+ Buchhaltung.Utils+ Buchhaltung.ZipEdit2+ Buchhaltung.Zipper+ default-language: Haskell2010+ ghc-options: -threaded+ build-depends:+ Decimal >= 0.4.2+ , ListLike+ , MissingH+ , aeson >= 1.0.0+ , ansi-wl-pprint+ , array+ , async+ , base >= 4.0.0.0 && < 5+ , boxes+ , bytestring+ , lens+ , cassava >= 0.4.1.0+ , containers+ , data-default+ , deepseq+ , directory+ , edit-distance+ , file-embed+ , filepath+ , formatting+ , hashable+ , haskeline+ , hint+ , hledger >= 1.0.0+ , hledger-lib >= 1.0.0+ , lifted-base+ , megaparsec >= 5.0.0+ , monad-control + , mtl+ , optparse-applicative >= 0.13+ , parsec+ , process >= 1.1.0.2+ , regex-compat+ , regex-tdfa+ , regex-tdfa-text+ , safe+ , semigroups+ , split+ , strict+ , temporary+ , text+ , time+ , transformers+ , unordered-containers+ , vector+ , yaml+++Source-repository head+ Type: git+ Location: http://github.com/johannesgerer/buchhaltung
+ buchhaltung_autocomplete.bash view
@@ -0,0 +1,15 @@+_buchhaltung()+{+ local cmdline+ local IFS=$'+'+ CMDLINE=(--bash-completion-index $COMP_CWORD)++ for arg in ${COMP_WORDS[@]}; do+ CMDLINE=(${CMDLINE[@]} --bash-completion-word $arg)+ done++ COMPREPLY=( $(/usr/bin/buchhaltung "${CMDLINE[@]}") )+}++complete -o filenames -F _buchhaltung buchhaltung
+ buchhaltung_autocomplete.zsh view
@@ -0,0 +1,16 @@+autoload bashcompinit; bashcompinit+_buchhaltung()+{+ local cmdline+ local IFS=$'+'+ CMDLINE=(--bash-completion-index $COMP_CWORD)++ for arg in ${COMP_WORDS[@]}; do+ CMDLINE=(${CMDLINE[@]} --bash-completion-word $arg)+ done++ COMPREPLY=( $(/usr/bin/buchhaltung "${CMDLINE[@]}") )+}++complete -o filenames -F _buchhaltung buchhaltung
+ config.yml view
@@ -0,0 +1,55 @@+users:+ - name: jo+ ledgers:++ # main ledger file passed to `hledger` or `ledger` and used to create the commit message.+ # this file should (at least) include the other files.+ mainLedger: jo/ledger.ledger++ # optional: extra ledger file for hledger+ # mainHledger: <optional>++ # ledger file for 'import'ed transactions.+ # they are also used as suggestions for 'add'ing.+ imported: jo/import.ledger++ # ledger file for manually 'add'ed transactions+ addedByThisUser: jo/entered_by_jo.ledger++ # optional: ledger file for transactions entered by other users+ addedByOthers: jo/entered_by_others.ledger++ # optional: account prefix used when 'add'ing transactions for other users+ accountPrefixOthers: Accounts receivable:Friends++ # regex matchind accounts whose transactions should not be suggested when 'add'ing+ ignoredAccountsOnAdd:+ - "Transfer"+ - "Cash"++ # bank accounts (grouped by bank id) and their corresponding ledger accounts+ # to be used when 'import'ing+ bankAccounts:+ 1243567:+ 8333777: "Assets:Bank Accounts:Bank A:Checking"+ 3827723: "Assets:Bank Accounts:Bank A:Savings"+ <bank identifier code>:+ <AccountNumber>: "<LedgerAccount>"+ Paypal:+ "<username>": "<LedgerAccount>"+ aqBanking:+ configDir: jo/aqbanking+ connections:+ - user: '<user>'+ blz: '<bank identifier code>'+ url: "<url>"+ name: <User Name>+ hbciv: HBCI300 # or one of HBCI201 | HBCI210 | HBCI220 | HBCI300+ type: PinTan # or Other (see 'Manual AqBanking setup' in the documentation)+ - name: alice+ ledgers:+ mainLedger: alice/ledger.ledger+ imported: alice/import.ledger+ addedByThisUser: alice/entered_by_alice.ledger+ addedByOthers: alice/entered_by_others.ledger+ accountPrefixOthers: Accounts receivable:Friends
+ match.md view
@@ -0,0 +1,36 @@+```+(Reading journal from+"~/.buchhaltung/jo/import.ledger")+...++Learning: Accounts receivable:companies:Simyo+Learning: Accounts receivable:companies:Simyo++Field | Value+------------------ | -------------------------+date | 2015/04/21+formatName | aqBanking+formatVersion | 4+localAccountNumber | 234789183+localBankCode | 234789183+localName | Johannes Gerer+purpose | LASTSCHRIFT/BELAST.+purpose1 | 10119238260151-24059470+purpose2 | END-TO-END-REF.:+purpose3 | 1011923826+purpose4 | COR1 / MANDATSREF.:+purpose5 | SIMC1405180003419290+purpose6 | GLÄUBIGER-ID:+purpose7 | DE84ZZZ00000437964+purpose8 | Ref. IG215110B0600526/690+remoteName | SIMYO GMBH+value_currency | EUR+value_value | -4.90+valutadate | 2015/04/21++Current Transaction: 1, Remaining: 486+uncertainty: 53.80 Simyo:companies:Accounts receivable+[<, >, save, RET]: save++1 Transactions were changed+```
+ src/Buchhaltung/AQBanking.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_HADDOCK ignore-exports #-}+module Buchhaltung.AQBanking where++import Buchhaltung.Common+import Control.Monad.RWS.Strict+import Data.Maybe+import qualified Data.Text as T+import Formatting ((%))+import qualified Formatting.ShortFormatters as F+import System.Directory+import System.FilePath+import System.Process as P++-- * The Monad Stack and its runner++type AQM = CommonM (AQConnection, AQBankingConf)++-- | Runs an AQBanking Action for all connections of the selected user+runAQ :: FullOptions () -> AQM a -> ErrorT IO [a]+runAQ options action = fst <$> evalRWST action2 options ()+ where action2 = do+ user <- user+ aqconf <- maybeThrow ("AQBanking not configured for user "%F.sh)+ ($ user) return $ aqBanking user+ forM (connections aqconf) $ \conn ->+ withRWST (\r s -> (r{oEnv = (conn,aqconf)}, s)) action++-- * Direct access to the executables++runProc ::+ (FilePath -> [String] -> IO a)+ -> [String] -> ([FilePath], FilePath)+ -> AQM a+runProc run args (argsC, bin) = liftIO $ run bin $ argsC ++ args++callAqhbci :: AAQM ()+callAqhbci args = runProc callProcess args+ =<< askExec aqhbciToolExecutable "aqhbci-tool4" "-C"++runAqbanking'+ :: (FilePath -> [String] -> IO b) -> AAQM b+runAqbanking' prc args = do+ args' <- addContext args+ runProc prc args'+ =<< askExec aqBankingExecutable "aqbanking-cli" "-D"++++callAqbanking :: AAQM ()+callAqbanking = runAqbanking' callProcess++readAqbanking :: AAQM String+readAqbanking = runAqbanking' $ readProcess'++type AAQM a = [String] -> AQM a++-- * Higher Level of Abstraction++aqbankingListtrans :: Bool+ -- ^ request new transactions+ -> AQM T.Text+aqbankingListtrans doRequest = do+ when doRequest $+ callAqbanking ["request"+ , "--transactions"+ , "--ignoreUnsupported"+ ]++ T.pack <$> readAqbanking ["listtrans"+ ]++aqbankingSetup :: AQM ()+aqbankingSetup = do+ path <- askConfigPath+ conn <- readConn return+ exists <- liftIO $ doesPathExist path+ when exists $ throwFormat+ ("Path '"%F.s%"' already exists. Cannot install into existing path.")+ ($ path)+ typ <- readConn $ return . aqType+ when (typ /= PinTan) $ throwError $ mconcat+ ["modes other than PinTan have to be setup manually. Refer to the "+ ,"AQBanking manual. Use the '-C' to point to the configured "+ ,"'configDir'."]+ liftIO $ createDirectoryIfMissing True path+ callAqhbci [ "adduser", "-t", "pintan", "--context=1"+ , "-b", aqBlz conn+ , "-u", aqUser conn+ , "-s", aqUrl conn+ , "-N", aqName conn+ , "--hbciversion=" <> toArg (aqHbciv conn)]+ callAqhbci [ "getsysid" ]+ callAqhbci [ "getaccounts" ]+ callAqhbci [ "listaccounts" ]++-- * Utils++addContext :: AAQM [FilePath]+addContext [] = return []+addContext args@(cmd:_) = do+ withC <- withContext cmd+ fmap (args ++) $+ if withC then (\x -> ["-c", x <.> "context"]) <$> askConfigPath+ else return []++withContext "listbal" = return True+withContext "listtrans" = return True+withContext "request" = return True+withContext "listaccs" = return False+withContext cmd = throwFormat+ ("'withContext' not defined for command '"%F.s%"'.")+ ($ cmd)++askConfigPath :: AQM FilePath+askConfigPath = do+ conn <- readConn return+ makeValid . (</> aqBlz conn <> "-" <> aqUser conn)+ <$> readConf (absolute . configDir)++readConn :: (AQConnection -> AQM a) -> AQM a+readConn f = f =<< reader (fst . oEnv)++readConf :: (AQBankingConf -> AQM a) -> AQM a+readConf f = f =<< reader (snd . oEnv)++-- | Find out executable path and two args selecting the config file+askExec+ :: (AQBankingConf -> Maybe FilePath)+ -> FilePath -- ^ default+ -> String -- ^ config path argument+ -> AQM ([FilePath], FilePath)+ -- ^ Path and Args+askExec get def arg = do+ path <- askConfigPath+ readConf $ return . ((,) [arg, path]) . fromMaybe def . get
+ src/Buchhaltung/Add.hs view
@@ -0,0 +1,896 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK ignore-exports #-}+module Buchhaltung.Add (add)+where++import Buchhaltung.Ask+import Buchhaltung.Common+import Buchhaltung.ZipEdit2 as ZE+import Buchhaltung.Zipper+import Control.Applicative+import Control.Arrow+import Control.Monad.RWS.Strict+import Data.Bits+import Data.Char+import Data.Decimal+import Data.Default+import Data.Either+import Data.Foldable+import Data.Function+import qualified Data.HashMap.Strict as HM+import Data.List+import qualified Data.List.NonEmpty as E+import qualified Data.ListLike as L+import qualified Data.ListLike.String as L+import qualified Data.Map as M+import Data.Maybe+import Data.Monoid ((<>))+import Data.Ord+import qualified Data.Set as S+import Data.String+import qualified Data.Text as T+import Data.Time.Calendar+import Data.Time.Clock+import Data.Time.Format+import Formatting (sformat, (%), (%.))+import qualified Formatting as F+import qualified Formatting.ShortFormatters as F+import Hledger hiding (at)+import Safe+import qualified Text.Megaparsec as MP hiding (State)+import qualified Text.Megaparsec.Text as MP+import Text.Parsec.Char+import Text.Parsec.Combinator (eof,many1)+import Text.Parsec.Prim (parse,try)+import Text.Parsec.String+import Text.Printf+import Text.Read (readEither)++-- DONE: clear an entry without entering a new one+-- TODO: percentage entry with memory+-- TODO: other ways to find uncleared transactions (e.g. by account)+-- DONE cancel unsuccesful search (and do ot force start of transaction entry)+-- TODO: do not propose transfer accounts?+-- TODO: change (existing) titles to include account+-- TODO: insert assertions? (for geldbeutetl or automatic for hbci)+-- TODO: check assertions (gegenseitige schulden)+-- TODO: do not jump to next suggestion (only after half)+-- TODO: betrag vorschlagen mit history? oder siehen nächstes+-- TODO: möglichenkeiten der eingabe von beträgen für beide parteien gleichzeitig+-- TODO: keine kontonamen in falscher reihenfolge vorschlagen++-- DONE in 8fbbc34: BUG: discard stil marks as cleared++-- * Types++type AddT' env m = RWST (FullOptions env) () Journal (ErrorT m)+++-- | Monad Transformer used to describe the 'add' program+--+-- The 'add' specific environment, that can contain a partner user++type AddOptions = FullOptions [Partner]++type AddT m = AddT' [Partner] m+++data Partner = Partner+ { pUser :: User+ , partnerAccount :: AccountName+ -- ^ partner's receivable/payable account in the user's ledger+ , userAccount :: AccountName+ -- ^ user's receivable/payable account in the partner's ledger+ , partnerLedger :: FilePath+ -- ^ partner's ledger+ }+ deriving (Show, Eq)++-- | Extract partner information from the env and throw errors if there are any+-- readPartner :: (MonadReader AddOptions m, MonadError Msg m)+-- => (Partner -> a) -> m (Maybe a)+-- readPartner f = reader $ fmap f . oEnv++-- -- | Extract partner user+partners+ :: (MonadReader AddOptions m, MonadError Msg m) => m [Partner]+partners = reader oEnv++-- * Entry point++add :: AddT' [Username] IO ()+add = do+ partner <- mapM (toPartner <=< lookupUser) =<< reader oEnv+ liftIO . putStr =<< hello+ withRWST (\r s -> (r{oEnv = partner}, s)) $ do+ forever mainLoop++-- | Convert given 'Username' to 'Partner'.+toPartner :: Monad m => User -> AddT' env m Partner+toPartner part = do+ Partner part+ <$> receivablePayable True part+ <*> receivablePayable False part+ <*> maybeThrow msg ($ name part) return (addedByOthers $ ledgers part)+ where msg = "ledgers.addedByOthers not configured for '"%F.sh%"'"+++-- | Welcome message+hello :: Monad m => AddT' env m String+hello = do+ un <- readUser name+ j <- get+ return $ intercalate "\n\n" [+ "Hi "<> fshow un <> "!"+ ,"Use readline keys to edit, use tab key to complete account names."+ ,"A code (in parentheses) may be entered following transaction dates."+ ,"A comment may be entered following descriptions or amounts."+ , show ( length $ jtxns j) ++ " Transactions found"+ ]+++-- | main user interaction loop+mainLoop :: AddT IO ()+mainLoop = do+ liftIO $ putStr "\n\nStarting new transaction...\n"+ (iAm, match) <- sugTrans+ let ask j = do iDa <- askDate Nothing+ iDe <- askDescription Nothing+ iAc <- myAskAccount j Nothing (Just "learn") (Left "Enter source account" )+ return (nulltransaction{tdate=fst iDa, tcode=snd iDa+ ,tdescription=iDe}+ ,iAc,iAm)+ useMatch t = return ( nulltransaction{tdate=tdate t,+ tdescription=tdescription t}+ ,paccount p2, AA "" Nothing $ negate $ pamount p2)+ where _:(p2:_) = tpostings t+ -- ,paccount p3, ("",negate $ pamount p3))+ -- where p3 = fromMaybe (pos!!2) $ asum $+ -- (\x -> return x <$> extractSource "HBCI" (pcomment x)) <$> pos+ -- pos = tpostings t+ -- PROBLEM1: it's not HBCI, instead sugTrans and clearSecondPosting+ -- emphazises on the "second" posting+ (transa,iAc,iAm2) <- maybe (get >>= liftIO . ask) useMatch match+ suggs <- suggestedPostings iAc $ Just iAm2+ result <- edit myEd transa suggs moveToNextEmpty+ saveAndClear match (isJust result) =<< finishTransaction True result++-- | Saves transaction into the designated ledgers files of each user,+-- and clears the transaction tht was matched (conditional on a 'Bool'+-- argument)+saveAndClear :: Maybe Transaction+ -- ^ matching transaction for clearing+ -> Bool -- ^ clear the matching transactions+ -> (Maybe Transaction, [(Partner, Transaction)])+ -- ^ transactioons to be saved: ((user's,other's),+ -> AddT IO ()+saveAndClear match clearIt (userT, partnerTS) = do+ j <- get+ let saveMine Nothing = clear j+ saveMine (Just res) = do+ -- clear the first posting, of the new transaction, if there was a+ -- match -- ReferenceA+ let newt = (if isJust match then clearNthPosting 0 else id) res+ -- add it to the user's journal (+ file)+ file <- readLedger addedByThisUser+ j' <- myJournalAddTransaction file [newt]+ infoNewTx =<< user+ -- clear the matching transactions second posting in the file+ clear j'+ clear j = maybe (return j)+ (saveChanges . changeTransaction .+ (:[]) . clearSecondPosting) $ guard clearIt *> match+ savePartners (partner, tx) = do+ myJournalAddTransaction (partnerLedger partner) [tx]+ infoNewTx $ pUser partner+ j' <- saveMine userT+ mapM savePartners partnerTS+ put j'+++clearSecondPosting :: Transaction -> (Transaction, Transaction)+clearSecondPosting t = (t, clearNthPosting 1 t)+++infoNewTx = liftIO . L.putStr .+ sformat ("\nNew transaction created for '" %F.sh% "'\n") . name++-- | Split 'EditablePosting's in User's Postings and (Partner,+-- Postings, Open Balance)+split :: [EditablePosting] -> ([Posting],+ [(Partner, E.NonEmpty Posting, MixedAmount)])+split = second (fmap h . E.groupBy (on (==) fst))+ . partitionEithers . mapMaybe f+ where+ f :: EditablePosting -> Maybe (Either Posting (Partner, Posting))+ f x = either (const Left) ((Right .) . (,)) (present $ epUser x)+ <$> epPosting x+ h :: E.NonEmpty (Partner, Posting)+ -> (Partner, E.NonEmpty Posting, MixedAmount)+ h x = (fst $ E.head x, snd <$> x, sum $ pamount . snd <$> x)++-- | generate the main and possibly the other users' transactions+finishTransaction :: (MonadIO m, MonadReader AddOptions m)+ => Bool+ -- ^ require balanced transactions+ -> Maybe (Transaction, [EditablePosting])+ -- ^ the transaction and postings to be combined+ -> m (Maybe Transaction, [(Partner, Transaction)])+ -- ^ (user's, partners') transactions+finishTransaction _ Nothing = return (Nothing, [])+finishTransaction check (Just (tr,postings)) = do+ time <- liftIO getCurrentTime+ us <- user+ let+ (userP, partnerPS) = split postings++ userT = if null x then Nothing else Just $ toTP x+ where x = userP ++ concatMap userTransfer partnerPS+ userTransfer (partner, _, sum) =+ nullP (partnerAccount partner) sum++ partnerT (partner, ps, sum) = (,) partner $+ toTP $ nullP (userAccount partner) (negate sum)+ ++ E.toList ps++ toTP ps = (if check then either err id . balanceTransactionIfRequired+ else id)+ tr {tpostings = increasePrec <$> ps ,tcomment = comment}++ nullP acc am = if isReallyZeroMixedAmount am then []+ else [nullposting{paccount = acc+ ,pamount = am}]++ comment = sformat ("Entered on "%F.sh%" by 'buchhaltung' user "%F.sh)+ (iso8601 time) $ name us+ err = (error.("shit, it should be balanced, check source code\n\n"++))+ increasePrec p = p{pamount = setMixedAmountPrecision maxprecisionwithpoint+ $ pamount p}+ return $ (userT, partnerT <$> partnerPS)++iso8601 :: UTCTime -> String+iso8601 = formatTime defaultTimeLocale "%FT%TZ"++-- | add transaction to ledger file+myJournalAddTransaction :: FilePath -> [Transaction] -> AddT IO Journal+myJournalAddTransaction relative trans = do+ file <- absolute relative+ liftIO $ ensureJournalFileExists file -- creates empty journal+ j <- get+ liftIO $ L.appendFile file+ $ "\n" <> intercalateL "\n\n" trans' <> "\n"+ return j{jtxns=jtxns j ++ trans }+ where trans' = L.dropWhileEnd (=='\n') . fshow <$> trans :: [T.Text]++++clearNthPosting :: Int -> Transaction -> Transaction+clearNthPosting n t = t{tpostings=p'}+ where p' = modifyNth (\x -> x{pstatus=Cleared}) n $ tpostings t+++-- * Transaction suggestions++data Asserted a = AA { aComment :: Comment+ , aAssertion :: Maybe Amount+ , aAmount :: a }+ deriving (Functor, Show)++instance Default AssertedAmount where+ def = AA "" Nothing $ mixed' nullamt++type AssertedAmount = Asserted MixedAmount++fromPosting :: Posting -> Asserted MixedAmount+fromPosting = AA <$> pcomment <*> pbalanceassertion <*> pamount++showAssertedAmount :: Asserted MixedAmount -> T.Text+showAssertedAmount a = showMixedAmount2 (aAmount a) <>+ maybe "" ((" = " <>) . showAmount2) (aAssertion a)+++-- | Ask an amount, and return transactions matching the entered+-- amount+sugTrans :: AddT IO (AssertedAmount, Maybe Transaction)+sugTrans = sugTrans' . fmap negate =<< askAmount (Just def)+ "Enter amount (zero for any transaction)" Nothing+ where sugTrans' answ@AA{ aAmount = iAm, aAssertion = Nothing} = do+ accs <- S.fromList . HM.elems <$> askAccountMap+ user <- readUser id+ let+ f user Transaction{tpostings=p1:(p2:_)} =+ -- the first posting's account is part of the accounts+ -- automaticcaly handled by csv2ledger+ (paccount p1 `S.member` accs)+ -- the first amount of the first posting matched the entered+ -- amount in absolute values+ && (on (==) (abs.aquantity.head.amounts) iAm ( pamount p1 )+ -- or the entered amount is zero+ || mixed' nullamt == iAm+ -- or the amount occurs in the comment of the second+ || (comma.fshow.abs.aquantity.head.amounts $ iAm)+ `L.isInfixOf` pcomment p2 )+ -- the second posting is not cleared+ && not (pstatus p2 == Cleared)+ -- doch nicht (siehe notiz vom [2013-06-02 Sun]):+ -- no transaction exists offsetting the second+ -- posting (e.g. for transactions entered, before they were+ -- paid)+ -- && fromMaybe True ( flip Set.notMember s <$>+ -- toMyP t p2{pamount=negate $ pamount p2})++ -- ignore certain accounts+ && (not $ isIgnored user $ paccount p2)+ f _ _ = False+ -- s :: S.Set MyPosting+ -- s = error "doch benutzt?" -- Set.fromList $ toMyPs =<< jtxns j+ comma = T.replace "." ","+ selectMatch :: [Transaction]+ -> AddT IO (AssertedAmount, Maybe Transaction)+ selectMatch m = g =<< (liftIO $ choose $ show <$> m')+ where m' = take 20 $ sortBy (flip $ comparing tdate) m+ g Manual = return (answ, Nothing)+ g (Choose i) = return $ (answ, Just $ atNote "selectMatch" m' i)+ g Reenter = sugTrans+ selectMatch =<< gets (filter (f user) . jtxns)+ sugTrans' a = return (a, Nothing)+-- data MyPosting = MyP {mypDay::Day, mypAcc::AccountName,mypAmt::Amount}+-- deriving (Show)++-- toMyPs t = catMaybes [ toMyP t p | p <- tpostings t ]++-- toMyP t p@Posting{pstatus=Uncleared} =+-- MyP (tdate t) (paccount p) <$> listToMaybe (amounts $ pamount p)+-- --take only first amount+-- toMyP _ _ = Nothing+++-- compareMyPs = comparing (acommodity.mypAmt) && (aquantity.mypAmt) && mypDay && mypAcc+-- where (&&) a b = a `Mo.mappend` comparing b+-- instance Ord MyPosting where+-- compare = compareMyPs+-- instance Eq MyPosting where+-- (==) = (EQ==).:compareMyPs+-- (.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d+-- (.:) = (.) . (.)++data Choice = Reenter | Manual | Choose Int++-- | user input: choose one from a list of choices+choose :: [String] -- ^ choices+ -> IO Choice+choose [] = return Manual+choose m = do+ putStr $ unlines $ reverse $+ zipWith pr [1..] m+ putStr $ unlines+ [if null m then ""+ else printf "{number}: use one of the above %d transactions" len+ ,"'m': enter transaction manually"+ ,"'r': enter new amount to find existing transations"]+ either ((>> choose m) . print) return+ =<< parse (menup len)"menu parser" <$> getLine+ where pr n t = show n ++ ")\n" ++ t+ len = length m++menup :: Int -> Parser Choice+menup limit = stripP $+ try (try (char 'r' >> return Reenter)+ <|> (char 'm' >> return Manual))+ <|> do int <-pred . read <$> many1 digit+ if int < limit then return $ Choose int+ else fail "number too high"++stripP p = do r <- spaces >> p+ spaces >> eof >> return r+++-- * Main editing loop++-- | combines everything into an 'EditorConf'+myEd :: EditorConf (AddT IO) EditablePosting Transaction+myEd =+ EC { getchar = Just myGetchar+ , ZE.display = dis+ , ecPrompt = const mainPrompt+ , actions = [+ ('c', ModifyAll clearTrans <> Done quiet+ ?? "Clear transaction")+ , ('n', ModifyAllM (addNewPosting False) ?? "Add new posting")+ , ('N', ModifyAllM (addNewPosting True)+ ?? "Add new posting for next user")+ , ('r', ModifyAll (assignOpenBalance 1.0)+ ?? "Assign open balance to account")+ , ('h', ModifyAll (assignOpenBalance 2.0)+ ?? "Assign half of open balance to account")+ , ('x', Modify removeAmount ?? "Remove current amount")+ , ('t', ModifyStateM editDescription ?? "Edit title")+ , ('d', ModifyStateM editDate ?? "Edit date")+ -- http://www.ledger-cli.org/3.0/doc/ledger3.html#Effective-Dates+ -- , ('D', ModifyStateM (editDate j) ?? "Edit effective date")+ , ('e', ModifyAllM editCurAmount ?? "Edit current amount")+ , ('+', ModifyAllM+ (modifyCurAmount (\o n -> fmap (on (+) replaceMissing+ $ aAmount n) o) False)+ ?? "Add to amount")+ , ('j', Fwd ?? "Move forward one item.")+ , ('k', Back ?? "Move backward one item.")+ , ('Q', Cancel ?? "discard entry and Quit")+ , ('m', Modify setMissing ?? "set amount to 'missing'")+ , ('s', Done checkDone ?? "Save entry")+ , ('c', Done checkDone ?? "Save entry")+ , ('u', Modify nextNotFirst ?? "Next user")+ , ('v', ModifyAll (assignOpenBalance (119/19)) ?? "Fill with VAT")+ , ('p', ModifyAllM+ ((<$> liftIO askPercent) . flip assignOpenBalance)+ ?? "Ask for percentage")+ ] ++ digitActions+ }+ where digitActions =+ [ (intToDigit n, ModifyAll (jumpTo n) ??+ ("Edit account"++[intToDigit n])) | n <- [0..9] ]+ dis LS{userSt=tr,ctx=z} = do+ -- j <- get+ return $ L.replicate 60 '~' <> "\n\n"+ <> fromString (showTransaction tr)+ -- <> fshow (jparsedefaultcommodity j, jcommodities j, jinferredcommodities j)+ <> showEditablePosting z++mainPrompt :: (L.ListLike m item, IsString m) => m+mainPrompt =+ "\n" <> intercalateL "\n" ( intercalateL " " <$> f) <> "\n"+ where f =+ [["[r]est ","[j]next","[u]ser ","[+]add","[t]itle","[?]Help ","[s]ave ","[p]%"]+ ,["[h]alf ","[k]prev","[n/N]ew","[e]dit","[d]ate ","[x]remove","[Q]discard","[v]AT"]+ ,[" "," "," ","[m]iss"," "," ","[c]lear "," "]]++quiet :: Monad m => a -> m (Maybe a)+quiet = return . Just++-- | clear all postings+clearTrans :: Zipper EditablePosting -> Zipper EditablePosting+clearTrans = differentiate . fmap f . integrate'+ where f x = x{epPosting=Nothing}++-- | change user of current posting, but not for the first posting+-- ReferenceA+nextNotFirst :: EditablePosting -> EditablePosting+nextNotFirst s | epNumber s > 0 = next s+ | otherwise = s++balanceTransactionIfRequired+ :: Transaction -> Either String Transaction+balanceTransactionIfRequired tx = do+ br <- mapM (balanceRequirement . ($ tx))+ [realPostings, balancedVirtualPostings]+ if not $ any required br then return tx+ else do+ when (not $ all possible br) $ throwError+ $ "Not implemented: this transaction has some postings that "+ ++ "need to be balanced while others cannot be balanced."+ ++ show br+ balanceTransaction Nothing tx++data Balancing = B { possible :: Bool+ , required :: Bool+ }+ deriving (Show)++-- | check, if the transaction should be passed through+-- `balanceTransaction` to infer missing amounts+balanceRequirement+ :: MonadError String m => [Posting] -> m Balancing+balanceRequirement [] = return $ B True False+balanceRequirement ps =+ if assignments > 0 then+ if length noAmount - assignments <= 1+ then return $ B False False+ else throwError $ "There cannot be more than one "+ ++ "posting with neither amount nor assertion"+ else return $ B True True+ where noAmount = filter hasAmount ps+ assignments = length $ filter+ (isJust . pbalanceassertion) noAmount++-- | Try to balance the transactions and present the final+-- transactions+checkDone :: LState EditablePosting Transaction ->+ AddT IO (Maybe (LState EditablePosting Transaction))+checkDone st@LS{userSt = trans, ctx = postings} = do+ user <- user+ (userT, partnerT) <- finishTransaction False $ Just (trans, integrate postings)+ let+ txs :: [(User, Either String Transaction)]+ txs = second balanceTransactionIfRequired+ <$> maybeToList ((,) user <$> userT) ++ fmap (first pUser) partnerT+ res <- liftIO $ mapM g txs+ return$ if and res then Just st else Nothing+ where g (u,tx) = either (showR "ERROR" False u)+ (showR "Balanced Transaction" True u . show) tx+ showR title ret user msg = do+ L.putStrLn $ sformat+ ("####### "%F.sh%": "% (F.center 20 ' '%.F.s) %" #######\n\n"%F.s%"\n")+ (name user) title msg+ return ret++-- * Asking (with completion)++askDescription :: Maybe T.Text -- ^ default+ -> IO T.Text+askDescription = editLoop Right d Nothing Nothing (Left d)+ where d = "Title" :: IsString a => a++-- | uses 'dateandcodep'+askDate :: Maybe Day -- ^ default+ -> IO (Day, T.Text)+askDate def = do+ today <- getCurrentDay+ let+ defday = fromMaybe today def+ -- defday = either (error . ("cannot parse default date:\n"++) . show)+ -- (fixSmartDate today) $ (parse smartdate "" . lowercase) $ showDate today+ extract :: T.Text -> Either String (Day, T.Text)+ extract input = ("Date parsing error "++).show +++ first+ (fixSmartDate today)+ $ MP.runParser dateandcodep "" input+ editLoop extract "Date" (Just ((defday,""), fshow defday))+ complList (Left "Date") $ fshow <$> def+ where complList = Just ["january"+ , "february"+ , "march"+ , "april"+ , "may"+ , "june"+ , "july"+ , "august"+ , "september"+ , "october"+ , "november"+ , "december"+ , "today"+ , "yesterday"+ , "tomorrow"+ , "last"+ , "this"+ ,"next"]++-- | HLedger's 'smartdate' and code+dateandcodep :: MP.Parser (SmartDate, T.Text)+dateandcodep = do d <- smartdate+ c <- optional codep+ many spacenonewline+ MP.eof+ return (d, maybe "" T.pack c)++myAskAccount j = askAccount completionList+ where completionList = nub $ sort [ paccount p | t <- jtxns j+ , p <- tpostings t]++askAmount :: Maybe AssertedAmount -- ^ default value, if "" is entered+ -> T.Text -- ^ prompt+ -> Maybe T.Text -- ^ initial+ -> AddT IO AssertedAmount+askAmount def pr init = do+ j <- get+ liftIO $ editLoop (extract j) "Amount"+ ((id &&& showAssertedAmount) <$> def) Nothing (Left pr) init+ where+ extract :: Journal -> T.Text -> Either String AssertedAmount+ extract j input = left show $ (\a -> a { aComment = cmt })+ <$> parseAmount j am+ where (am, cmt) = textstrip *** (textstrip . L.dropWhile (==';')) <<< L.break (==';') $ input+ :: (T.Text, T.Text)++-- -- | Parse and update an amount to equal its 'show' value+-- --+-- -- this is required to ensure, that the saved transaction equals the+-- -- edited and balanced transaction.+-- toShow :: Journal -> MixedAmount -> MixedAmount+-- toShow j (Mixed ams) = Mixed $ fmap g ams+-- where g = either (error.show) id . parseAmount j . fshow+++parseAmount+ :: Journal+ -> T.Text -> Either (MP.ParseError Char MP.Dec) AssertedAmount+parseAmount j = parseWithState' j $ ((flip $ AA "") <$>+ (fmap (Mixed . pure) $ amountp MP.<|> return missingamt)+ <*> partialbalanceassertionp+ ) <* MP.eof++-- | (unused) overwrite upstream behavior to use defined or incurred+-- commodities+_amountp2 = MP.try leftsymbolamountp+ MP.<|> MP.try rightsymbolamountp+ MP.<|> nosymbolamountp2++nosymbolamountp2 :: Monad m => JournalStateParser m Amount+nosymbolamountp2 = do+ (q,prec,mdec,mgrps) <- lift numberp+ p <- priceamountp+ -- apply the most recently seen default commodity and style to this commodityless amount+ defcs <- getDefaultCommodityAndStyle2 <$> get+ let (c,s) = case defcs of+ Just (defc,defs) -> (defc, defs{asprecision=max (asprecision defs) prec})+ Nothing -> ("", amountstyle{asprecision=prec, asdecimalpoint=mdec, asdigitgroups=mgrps})+ return $ Amount c q p s+ MP.<?> "no-symbol amount"++getDefaultCommodityAndStyle2+ :: Journal+ -> Maybe (CommoditySymbol,AmountStyle)+getDefaultCommodityAndStyle2+ Journal{jparsedefaultcommodity=def+ ,jcommodities=comms+ ,jinferredcommodities=inferred} =+ let mm = listToMaybe . M.toList in+ asum+ [def+ ,traverse cformat =<< mm comms+ ,mm inferred+ ]+++askPercent :: IO Decimal+askPercent = editLoop extr "percent"+ (Just ((,).prep <*> fshow $ def)) Nothing (Left "Percentage") Nothing+ where+ extr :: T.Text -> Either String Decimal+ extr s = show +++ prep $ readEither $ T.unpack s+ def = -1.5 :: Decimal+ prep = (100*).recip++-- * Posting and Suggestions+++-- | Type holding suggested or temporary postings+data EditablePosting = EditablePosting { epPosting :: Maybe Posting+ , epFreq :: Maybe Int+ , epAccount :: AccountName+ , epNumber :: Int+ , epUser :: Zipper (Either User Partner)+ -- ^ zipper of possible user+ }++type EditablePostings = Zipper EditablePosting++-- | construct an 'EditablePosting'+editablePosting account amt n = do+ ps <- partners+ user <- user+ return $ addPosting account amt EditablePosting+ { epAccount = account+ , epFreq=Nothing+ , epNumber=n+ , epPosting = Nothing+ , epUser = differentiate $ E.cycle $ Left user E.:| (Right <$> ps)}++-- | generate and add new 'Posting' to 'EditablePosting'+addPosting+ :: AccountName+ -> Maybe AssertedAmount -> EditablePosting -> EditablePosting+addPosting _ Nothing s = s+addPosting account (Just (AA cmt ass iam)) s =+ s{epPosting=Just nullposting+ { paccount=account+ , pcomment = cmt+ , pbalanceassertion = ass+ , pamount = iam}}++setMissing :: EditablePosting -> EditablePosting+setMissing ep = addPosting (epAccount ep)+ (Just $ missingmixedamt <$ maybe def fromPosting+ (epPosting ep)) ep++++removeAmount :: EditablePosting -> EditablePosting+removeAmount ep = ep{epPosting=Nothing}++-- | jump to a certain element in a zipper+jumpTo :: Int -> Zipper a -> Zipper a+jumpTo n z' = atNote "jumpTo" (iterate fwd . differentiate . integrate' $ z') n++editDate :: LState a Transaction -> AddT IO (LState a Transaction)+editDate s@LS{userSt=t@Transaction{tdate=d}} = liftIO $ do+ iDa <- askDate (Just d)+ return s{userSt=t{tdate=fst iDa,tcode=snd iDa}}++editDescription :: LState a Transaction -> AddT IO (LState a Transaction)+editDescription s@LS{userSt=t@Transaction{tdescription=d}} = liftIO $ do+ iDe <- askDescription (Just d)+ return s{userSt=t{tdescription=iDe}}++-- | edit the amount of the selected posting+editCurAmount :: EditablePostings -> AddT IO EditablePostings+editCurAmount = modifyCurAmount (const id) True++-- | modfiy current amount by asking for a new amount, that is+-- combined with the old to get a new amount (e.g. with (+))+modifyCurAmount ::(AssertedAmount -> AssertedAmount -> AssertedAmount)+ -- ^ oldAmout -> enteredAmount -> newAmount+ -> Bool -- ^ Show old amound+ -> EditablePostings -> AddT IO EditablePostings+modifyCurAmount new showO z@LZ{past=(s@EditablePosting{epAccount=ac} E.:| ps)} = do+ iAm <- askAmount olda ("Amount for " <> ac) solda+ return $ moveToNextEmpty z+ { past = addPosting ac+ (Just $ maybe iAm (flip new iAm) olda) s E.:| ps }+ where olda = fromPosting <$> epPosting s+ solda = guard showO *> fmap showAssertedAmount olda++replaceMissing :: MixedAmount -> MixedAmount+replaceMissing amt | normaliseMixedAmount amt == missingmixedamt = nullmixedamt+ | True = amt++++-- | Hardcoded default number of suggested accounts+defNumSuggestedAccounts :: Int+defNumSuggestedAccounts = 20+++-- | retrieve a number of suggested contra postings for a given+-- account, sort frequency of that contra account for the given+-- account.+--+-- duplicate each posting for both users, but only if the+-- other user's account is present in the suggestions.+suggestedPostings :: MonadIO m+ => AccountName+ -> Maybe AssertedAmount+ -> AddT m (E.NonEmpty EditablePosting)+suggestedPostings account am = do+ j <- get+ filterPref <- maybe id (\x -> filter $ not . L.isPrefixOf (x <> ":") . epAccount)+ <$> readUser accountPrefixOthers+ nP <- succ . length <$> partners+ let+ toEp l = editablePosting (head l) Nothing 0+ >>= \x -> return $ x{epFreq=Just $ length l}+ matches = concatMap tail $ filter filt $+ ((paccount<$>) . tpostings) <$> jtxns j+ sugaccounts <- sortBy (flip $ comparing epFreq)+ <$> mapM toEp (group $ sort matches)+ let+ s = filterPref sugaccounts+ transformed :: [EditablePosting]+ transformed = if length sugaccounts == length s then s+ else do x <- s+ take nP $ iterate next x+ firstP <- editablePosting account am 0 -- ReferenceA+ num <- fromMaybe defNumSuggestedAccounts <$>+ readUser numSuggestedAccounts+ return $ (E.:|) firstP $ take (pred num) $+ zipWith (\n p -> p{epNumber=n}) [1..] transformed+ where+ filt x = account == head x && not ( null x )++-- | change posting's user to the next user+next :: EditablePosting -> EditablePosting+next s = s{epUser = fwd $ epUser s}++roundP :: EditablePosting -> EditablePosting+roundP p = p{epPosting = r1 <$> epPosting p}+ where r1 p = p{pamount = normalizeMixedAmountWith g $ pamount p}+ g a = roundTo (fromIntegral $ asprecision $ astyle a) $ aquantity a++++-- | assign the 'Transaction''s open balance to an empty 'EditablePosting'+assignOpenBalance :: Decimal -> EditablePostings -> EditablePostings+assignOpenBalance c old@LZ{past=(pr@EditablePosting{epAccount=sac} E.:| ps)} =+ moveToNextEmpty $ old{past= roundP (newp $ epPosting pr) E.:| ps}+ where balance = divideMixedAmount (totalBalance all) c+ all = integrate old+ newp Nothing = addPosting sac (Just $ AA "" Nothing balance) pr+ newp (Just op) = pr{epPosting = Just op{pamount= balance + pamount op }}++showEditablePosting :: EditablePostings -> T.Text+showEditablePosting LZ{past= pr E.:| ps ,future=fut} =+ renderTable (replicate 4 AlignCenter,replicate 4 AlignLeft,+ [ "Account", "Amount", "Assertion", "Frequency"])+ [ let mark = if marked then "->" else " " :: String+ in [+ sformat (F.d % "," %F.sh% " " %F.s% " " %F.st)+ (epNumber x) (either name (name.pUser) $ present $ epUser x) mark+ $ epAccount x+ ,maybe "" (showMissing . pamount) $ epPosting x+ ,maybe "" (("= " <>) . showAmount2)+ $ pbalanceassertion =<< epPosting x+ ,maybe "" fshow $ epFreq x+ ] | (marked,x) <- postings ]+ $ Just ["Open Balance",balance,""]+ where balance = showMixedAmount2 $ totalBalance $ snd <$> postings+ postings = reverse ((,) True pr : mark ps) ++ mark fut+ mark = ((,) False <$>)+ showMissing amt | normaliseMixedAmount amt == missingmixedamt = "missing"+ | True = showMixedAmount2 amt++totalBalance :: [EditablePosting] -> MixedAmount+totalBalance = negate . sum . fmap pamount . mapMaybe epPosting++showAmount2 :: Amount -> T.Text+showAmount2 = showMixedAmount2 . mixed'++showMixedAmount2 :: MixedAmount -> T.Text+showMixedAmount2 amt = T.pack $ showMixedAmountWithPrecision maxprecisionwithpoint amt++-- | ask for new account (display old as default) and use existing+-- posting, if same account without a posting/amount already exists or+-- append.+addNewPosting :: Bool -- ^ for next partner+ -> EditablePostings -> AddT IO EditablePostings+addNewPosting forNext old' = do+ j <- get+ let postings = integrate old'+ nextP = (if forNext then fwd else id)+ $ epUser $ present old'+ account <- liftIO $ myAskAccount j+ (Just $ epAccount $ present old') Nothing $ Left "Account"+ new <- editablePosting account Nothing $ length postings+ let loop (ep:eps) done =+ if isNothing (epPosting ep)+ && epAccount ep == account+ && on (==) present nextP (epUser ep)+ then LZ (addPosting account Nothing ep E.:| done) eps+ else loop eps (ep:done)+ loop [] done = LZ (new E.:| done) []+ return $ modifyPresent (\x -> x{epUser = nextP}) $ loop postings []+++-- | move the focus to the next empty posting+moveToNextEmpty :: EditablePostings -> EditablePostings+moveToNextEmpty z = fromMaybe z $ find f zs+ where zs = take (length postings) $ iterate wrapFwd z+ postings = integrate' z+ f = isNothing . epPosting . E.head . past+ wrapFwd x = if null $ future x then differentiate postings+ else fwd x+++-- * Pretty Table Printer++-- a type for fill functions+data Align = AlignLeft | AlignRight | AlignCenter++-- functions that fill a string (s) to a given width (n) by adding pad+-- character (c) to align left, right, or center+fillLeft c n s = s <> L.replicate (n - L.length s) c+fillRight c n s = L.replicate (n - L.length s) c <> s+fillCenter c n s = L.replicate l c <> s <> L.replicate r c+ where x = n - L.length s+ l = x `div` 2+ r = x - l++-- converts a list of items into a table according to a list+-- of column descriptors+renderTable :: ([Align],[Align],[T.Text])+ -> [[T.Text]]+ -> Maybe [T.Text]+ -> T.Text+renderTable (headerAlign,rowAlign,header) rows footer =+ let widths = [maximum $ map L.length col |+ col <- transpose $ (header : rows) ++ maybeToList footer]+ :: [Int]+ separator = intercalateL "-+-" [L.replicate width '-' | width <- widths]+ fillCols fill cols = intercalateL " | " $+ zipWith3 (($).) fill widths cols+ in+ L.unlines ( fillCols headerFill header+ : separator+ : map (fillCols rowFill) rows+ ++ maybe []+ (\x -> [separator, fillCols rowFill x]) footer)+ where toFiller AlignLeft = fillLeft ' '+ toFiller AlignRight = fillRight ' '+ toFiller AlignCenter = fillCenter ' '+ headerFill = toFiller <$> headerAlign+ rowFill = toFiller <$> rowAlign
+ src/Buchhaltung/Ask.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+module Buchhaltung.Ask where++import Control.Arrow+import Control.Monad+import Control.Monad.Trans.Class+import Data.Char+import Data.Function+import Data.List+import Data.List.Split+import Data.Maybe+import Data.Monoid+import qualified Data.Text as T+import Hledger.Data.Types+import System.Console.Haskeline+import System.Console.Haskeline.History+++-- ############## Readline editing loops ############+ +editLoop :: MonadException m =>+ (T.Text -> Either String c) -- ^ input to value extractor+ -> String -- ^ history File suffix+ -> Maybe (c, T.Text) -- ^ Default value and its string+ -> Maybe [T.Text] -- ^ completion list+ -> Either T.Text T.Text -- ^ use promtp: Left promp ++ [Def]:, or Right prompt+ -> Maybe T.Text -- ^ intitial readline text+ -> m c+editLoop extractor = editLoopM $ return . extractor + +editLoopM :: MonadException m =>+ (T.Text -> m (Either String c)) -- ^ input to value extractor+ -> String -- ^ history File suffix+ -> Maybe (c, T.Text) -- ^ Default value and its string+ -> Maybe [T.Text] -- ^ completion list+ -> Either T.Text T.Text -- ^ use promtp: Left promp ++ [Def]:, or Right prompt+ -> Maybe T.Text -- ^ intitial readline text+ -> m c+editLoopM extract histFileSuf def completionList prompt init =+ runInputT2 settings loop+ where loop = do s <- fromJust <$> getInput+ let useDef = if s=="" then Just fst else Nothing+ tryExtract = do+ modifyHistory $ addHistoryRemovingAllDupes s+ either ((>> loop) . outputStr . (++"\n")) return =<<+ (lift $ extract $ T.pack s)+ maybe tryExtract return $ useDef <*> def+ getInput = getInputLineWithInitial (T.unpack prompt')+ (maybe "" T.unpack init, "")+ prompt' = either (<>(maybe ": " (\x -> " ["<> snd x <>"]: ") def)) id prompt :: T.Text+ settings = Settings { historyFile = histFile histFileSuf+ ,complete = completeFunc, autoAddHistory = False }+ completeFunc = maybe noCompletion (customCompl . fmap T.unpack)+ completionList+ customCompl list = completeWord Nothing "" -- don't break words on whitespace, since account names+ -- can contain spaces.+ $ \s -> return $ map (g s) $ filter (on f (toLower<$>) s) list+ where g s x = Completion y x False+ where y = concat $ "" : tail (ciSplitOn s x)+ f s = (||) <$> isPrefixOf s <*> isInfixOf (":"++s)+histFile suf = Just $ ".haskeline_history_"++suf++-- case insensitive char+newtype CiChar = CiChar { ciChar :: Char }+instance Eq CiChar where+ (==) = (==) `on` (toLower . ciChar)++-- ciSplitOn s x = (ciChar<$>) <$> (on splitOn (CiChar<$>) s x)+ciSplitOn s x = (ciChar<$>) <$> (on (split . onSublist) (CiChar<$>) s x)++myGetchar :: IO Char+myGetchar = fromJust <$> runInputT2 defaultSettings ( getInputChar "your action: ")++runInputT2 s i = runInputT s $ withInterrupt $ handle+ (\Interrupt -> outputStrLn "you will loose all unsaved data!" >> i) i++ +-- ziplist action +editHaskeline :: (a -> String) -> (a -> String -> a) -> a -> IO a+editHaskeline show modify v = liftM (modify v . fromJust) $+ runInputT2 defaultSettings{historyFile = Just ".haskeline_history"} $+ getInputLineWithInitial "edit: " (show v,"")++askAccount :: [AccountName] -- ^ completion list+ -> Maybe AccountName -- ^ default value, if "" is entered+ -> Maybe String -- ^ history file suffix+ -> Either T.Text T.Text -- ^ prompt+ -> IO AccountName+askAccount completionList def suf pr =+ revAccount2 <$> editLoop (maybe notNull (const Right) def)+ (fromMaybe "Account" suf)+ ((id &&& id) . revAccount2 <$> def)+ (Just $ revAccount2 <$> completionList) pr Nothing --def+ where notNull s = if s=="" then Left "Blank Account not allowed"+ else Right s+ +revAccount2 :: T.Text -> T.Text+revAccount2 = T.intercalate ":" . reverse . T.splitOn ":"
+ src/Buchhaltung/Commandline.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+module Buchhaltung.Commandline where++import Buchhaltung.AQBanking+import Buchhaltung.Add+import Buchhaltung.Common+import Buchhaltung.Importers+import Buchhaltung.Match+import Buchhaltung.OptionParsers+import Control.Arrow+import Control.DeepSeq+import Control.Exception+import Control.Monad.RWS.Strict+import Control.Monad.Reader+import qualified Data.Text as T+import Hledger.Data (Journal)+import Hledger.Read (readJournalFile)+import Options.Applicative+import System.Directory+import System.Environment+import System.FilePath+import System.Process+import Text.Printf++runMain :: IO ()+runMain = do+ opts <- evaluate . force =<<+ customExecParser (prefs $ showHelpOnError <> showHelpOnEmpty)+ =<< mainParser+ :: IO (RawOptions ())+ let+ prog :: ErrorT IO ()+ prog = do+ config <- liftIO $ readConfigFromFile $ oProfile opts+ run (oAction opts) =<< toFull opts config+ either (error . T.unpack) return =<< runExceptT prog++-- * Running Option Parsers and Actions++run :: Action -> FullOptions () -> ErrorT IO ()+run (Add partners) options =+ void $ withJournals [imported, addedByThisUser] options+ $ runRWST add options{oEnv = partners}++run (Import version file action) options = runImport action+ where runImport (Paypal puser) =+ importReadWrite paypalImporter (options' puser) file+ runImport (ComdirectVisa blz) =+ importReadWrite comdirectVisaImporter (options' blz) file+ runImport AQBankingImport =+ importReadWrite aqbankingImporter (options' ()) file+ options' env = options{oEnv = (env, version)}++run (Update version doMatch doRequest) options = do+ res <- runAQ options $ aqbankingListtrans doRequest+ void $ runRWST+ (mapM (importWrite $ iImport aqbankingImporter) res)+ options{oEnv = ((), version)} ()+ when doMatch $ run Match options++run (Commit args) options = flip runReaderT options $ do+ un <- readUser $ show . name+ dir <- takeDirectory <&> absolute =<< readLedger mainLedger+ bal <- lift $ runAQ options $ readAqbanking ["listbal"]+ sheet <- lift $ runLedger readProcess' ["balance", "-e", "tomorrow"] options+ liftIO $ do setCurrentDirectory dir+ callProcess "git" $ "commit":args +++ ["-m", intercalateL "\n" $ ["User " ++ un, ""]+ ++ bal ++ ["Balance Sheet:", sheet]]++run ListBalances options = void $ runAQ options $ callAqbanking ["listbal"]+ +run Setup options = void $ runAQ options aqbankingSetup++run Match options =+ withSystemTempDirectory "dbacl" $ \tmpdir -> do+ withJournals [imported] options $ match options{oEnv = tmpdir}++run (AQBanking args) options = void $ runAQ options $ callAqbanking args++run (Ledger args) options = runLedger callProcess args options++run (HLedger args) options =+ runLedger' callProcess cHledgerExecutable+ (maybe mainLedger const =<< mainHledger)+ args options++runLedger run = runLedger' run cLedgerExecutable mainLedger++runLedger' run getExec getLedger args options = flip runReaderT options $ do+ exec <- readConfig getExec+ ledger <- absolute =<< readLedger getLedger+ liftIO $ do+ setEnv "LEDGER" ledger+ run exec args++-- | performs an action taking a journal as argument. this journal is+-- read from 'imported' and 'addedByThisUser' ledger files+-- withJournals ::+-- [Ledgers -> FilePath]+-- -> FullOptions ()+-- -> (Journal -> ErrorT IO b) -> ErrorT IO b+withJournals+ :: (MonadError Msg m, MonadIO m) =>+ [Ledgers -> FilePath]+ -> Options User config env -> (Journal -> m b) -> m b+withJournals journals options f = do+ liftIO $ printf "(Reading journal from \n%s)\n...\n\n"+ $ intercalateL "\n" $ show <$> jfiles+ journal <- liftIO $+ -- to conquer problems with the `instance Monoid Journal`+ right mconcat' . sequence <$> mapM (readJournalFile Nothing Nothing False) jfiles+ either (throwError . T.pack) f journal+ where jfiles = runReader (mapM (absolute <=< readLedger)+ journals) options
+ src/Buchhaltung/Common.hs view
@@ -0,0 +1,407 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}++-- convert account transactions in csv format to ledger entries+-- pesco, 2009 http://www.khjk.org/log/2009/oct.html++module Buchhaltung.Common+ (module Buchhaltung.Common+ ,module Buchhaltung.Utils+ ,module Buchhaltung.Types+ ,textstrip+ )+where++import Buchhaltung.Types+import Buchhaltung.Utils+import Control.Applicative ((<$>))+import Control.Arrow+import Control.Lens hiding (noneOf, Getter, (<&>))+import Control.Monad.RWS.Strict+import Control.Monad.Writer+import qualified Data.Aeson as A+import Data.Char+import qualified Data.Csv as CSV+import Data.Csv.Parser+import Data.Decimal+import Data.Foldable+import qualified Data.HashMap.Strict as HM+import Data.List+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as E+import qualified Data.ListLike as L+import qualified Data.ListLike.String as L+import qualified Data.Map.Strict as M+import Data.Ord+import qualified Data.Set as S+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import Data.Text.Lazy.Encoding+import qualified Data.Text.Lazy.Encoding as S+import Data.Time.Calendar+import Data.Time.Format+import Data.Traversable (traverse)+import qualified Data.Vector as V+import Hledger.Data hiding (at)+import Hledger (textstrip)+import Hledger.Query+import Hledger.Read+import Hledger.Reports (defreportopts)+import Hledger.Reports.EntriesReport (entriesReport)+import System.IO+import Text.Parsec+import qualified Text.Parsec.Text as T+import qualified Text.PrettyPrint.Boxes as P+import Text.Printf++-- * CONFIGURATION+++-- * CSV PARSER+readcsv :: Char -> T.Text -> [[T.Text]]+readcsv sep = map (readcsvrow sep) . T.lines++readcsvrow :: Char -> T.Text -> [T.Text]+readcsvrow sep s = either (error.msg.show) id (parse (p_csvrow sep) "stdin" s)+ where msg = printf "CSV (sep %c) Parsing error:\n\n%v\n\n%s" sep s++p_csvrow :: Char -> T.Parser [T.Text]+p_csvrow sep = sepBy1 (p_csvfield sep) (char sep)++p_csvfield :: Char -> T.Parser T.Text+p_csvfield sep = fmap T.pack $ between (char '"') (char '"') p_csvstring+ <|> many (noneOf [sep])++p_csvstring :: T.Parser String+p_csvstring = many (noneOf "\"" <|> (string escapedDoubleQuotes >> return '"'))++escapedDoubleQuotes = "\\\""++parens :: Parsec T.Text () Int+parens = ( do char ('('::Char)+ m <- parens+ char ')'+ n <- parens+ return $ max (m+1) n+ ) <|> return 0++-- * dbacl output parser++testdbacl = parseTest (+ dbacl_parser [+ "Aktiva:Transfer:Visa"+ ,"Aktiva:Transfer"+ ]+ ) ("Aktiva:Transfer 134.32 Aktiva:Transfer:Visa Aktiva:Transfer:Visa 9129.73 a " :: String)++-- | parse dbacl output (see testdbacl for the format of dbacl's output)+dbacl_parse :: [AccountName]+ -> String+ -> Either ParseError [(AccountName,String)]+dbacl_parse accounts = fmap conv . parse (dbacl_parser sorted) ""+ where conv = map (liftM2 (,) fst (L.unwords . snd))+ sorted = sortBy (flip $ comparing T.length) $ accounts++dbacl_parser :: [AccountName] -> Parsec String () [(AccountName, [String])]+dbacl_parser accounts = weiter []+ where weiter :: [(AccountName, [String])] -> Parsec String () [(AccountName, [String])]+ weiter res = choice ((map (cat res) accounts) ++ [info res] )+ cat res y = do newc <- try $ do string $ T.unpack y+ space+ return y+ spaces+ weiter $ (newc,[]) : res+ info ((c,i):res) = do w <- try $ manyTill anyChar (many1 space)+ weiter $ (c,i <> [w]) : res+ <|> do { w <- many anyChar; return ((c,i++[w]):res) }+ info [] = fail "empty list in dbacl_parser: This was not planned"+++-- * Utilities++++idx :: (Eq a, Show a) => [a] -> a -> Int+idx xs x = maybe (error (show x++": CSV Field not found")) id (findIndex (==x) xs)++-- * Dates +++-- | Read the journal file again, before applying Changes (to not+-- overwrite possible changes, that were made in the mean time)+-- saveChanges :: String -- ^ journal path+-- -> (Journal-> (Journal, Integer)) +-- -> IO Journal+saveChanges+ :: (MonadReader (Options User config env) m, MonadIO m)+ => (Journal -> (Journal, Integer))+ -- ^ modifier, returning number of changed+ -> m Journal+saveChanges change = do+ journalPath <- absolute =<< readLedger imported+ liftIO $ do+ ej <- readJournalFile Nothing Nothing False -- ignore balance assertions+ journalPath+ -- print $ length todos+ -- putStr $ unlines $ show <$> todos+ -- either error (print.length.jtxns) ej+ let (j, n) = either error change ej+ if n == 0 then putStrLn "\nNo transactions were changed!\n"+ else do let res = showTransactions j+ writeFile journalPath res+ putStrLn $ "\n"++ show n ++" Transactions were changed"+ return j++mixed' :: Amount -> MixedAmount+mixed' = mixed . (:[])++showTransactions :: Hledger.Data.Journal -> [Char]+showTransactions = concatMap showTransactionUnelided .+ entriesReport defreportopts Hledger.Query.Any++-- * Lenses+ +jTrans :: Lens' Journal [Transaction]+jTrans = lens jtxns $ \j y->j{jtxns=y}++tPosts :: Lens' Transaction [Posting]+tPosts = lens tpostings $ \t y -> t{tpostings=y}++pAcc :: Lens' Posting AccountName+pAcc = lens paccount $ \p y -> p{paccount=y}++-- | replaces every matching transaction in the given journal counts+-- the number of changed transactions+changeTransaction+ :: [(Transaction, Transaction)]+ -> Journal+ -> (Journal, Integer)+changeTransaction ts = countUpdates (jTrans . traverse) h+ where+ h t1 = asum $ fmap g ts+ where g (t2, tNew) = guard (t1 == t2) *> Just tNew+ +-- | Update a traversal and count the number of updates+countUpdates :: Traversal' s a+ -> (a -> Maybe a)+ -> s -> (s, Integer)+countUpdates trav mod = second getSum . runWriter . trav g+ where g x = maybe (return x) ((tell (Sum 1) >>) . return) $ mod x++-- instance Monoid.Monoid Integer where+-- mempty = 0+-- mappend = (+)++data WithSource a = WithSource { wTx :: Transaction+ , wIdx :: Int+ -- ^ index of the posting with source+ , wPosting :: Posting+ , wSource :: Source+ , wInfo :: a+ }+ deriving (Functor)++++-- instance Hashable Day where +-- hash = fromInteger . toModifiedJulianDay+-- hashWithSalt salt = hashWithSalt salt . toModifiedJulianDay+ +-- instance Hashable Transaction where + +-- instance Hashable Posting where +-- instance Hashable PostingType where +-- instance Hashable MixedAmount where +-- instance Hashable Amount where + +-- | extracts the source line from a Transaction+extractSource :: ImportTag -> Transaction+ -> Either String (WithSource ())+extractSource tag' tx =+ left (<> "\nComments: "+ <> T.unpack (L.unlines $ pcomment <$> ps))+ $ g $ asum $ zipWith f [0..] ps+ where f i p = fmap ((,,) i p) . E.nonEmpty . tail+ . T.splitOn tag $ pcomment p+ tag = commentPrefix tag'+ g Nothing = Left $ printf "no comment with matching tag '%s' found." tag+ g (Just (i,p,n)) = do+ source <- A.eitherDecode' . S.encodeUtf8+ . TL.fromStrict . E.head $ n+ return $ WithSource tx i p source ()+ ps = tpostings tx++injectSource :: ImportTag -> Source -> Transaction -> Transaction+injectSource tag source t = t+ {tpostings = [ p1+ , p2{pcomment =+ commentPrefix tag <> TL.toStrict (json source)+ }]}+ where [p1,p2] = tpostings t++-- instance MonadReader (Options user Config env) m => ReaderM user env m++ +commentPrefix :: ImportTag -> T.Text+commentPrefix (ImportTag tag) = tag <> ": "+++trimnl :: T.Text -> T.Text+trimnl = mconcat . T.lines++-- * make CSV data easier to handle++-- http://hackage.haskell.org/package/cassava-0.4.1.0/docs/Data-Csv.html#t:NamedRecord+-- parseCsv :: CSV.FromField a => String -> V.Vector (HM.HashMap B.ByteString a)++type MyRecord = (HM.HashMap T.Text T.Text)++parseCsv :: Char -- ^ separator+ -> TL.Text -> ([T.Text], [MyRecord])+parseCsv sep = either error ((fmap T.decodeUtf8 . V.toList)+ *** V.toList)+ . CSV.decodeByNameWith CSV.defaultDecodeOptions+ { decDelimiter = fromIntegral $ ord sep }+ . encodeUtf8++getCsvConcat+ :: [T.Text] -> MyRecord -> T.Text+getCsvConcat x record = L.unwords $ flip getCsv record <$> x++getCsv :: T.Text -> MyRecord -> T.Text+getCsv c x = lookupErrD (show (HM.keys x)) HM.lookup c x++-- * Import Types+++data ImportedEntry' a s = ImportedEntry {+ ieT :: Transaction -- ^ transaction without postings (they will be inserted later)+ ,iePostings :: a+ ,ieSource :: s -- ^ source to check for duplicates and for Bayesian matching+ } deriving Show++type ImportedEntry = ImportedEntry' (AccountId, T.Text) Source+ -- ^ postings of [acount,amount]: only ImportedEntry with one+ -- posting is currently implemented in the statists functionality of+ -- Add.hs (See PROBLEM1) as well in the duplicates algorithm in 'addNew'++type FilledEntry = ImportedEntry' () Source++fromFilled :: FilledEntry -> Entry+fromFilled x = x{ieSource = Right $ ieSource x}+ +type Entry = ImportedEntry' () (Either String Source)++-- | helper function to create transaction for ImportedEntry+genTrans :: Day -> Maybe Day -> T.Text -> Transaction+genTrans date date2 desc =+ nulltransaction{tdate=date, tdescription=desc, tdate2=date2}++normalizeMixedAmountWith+ :: (Amount -> Decimal) -> MixedAmount -> MixedAmount+normalizeMixedAmountWith f (Mixed ams) = Mixed $ g <$> ams+ where g a = a{aquantity = normalizeDecimal $ f a}+ +data Importer env = Importer+ { iModifyHandle :: Maybe (Handle -> IO ())+ -- ^ e.g. 'windoof'+ , iImport :: T.Text -> CommonM (env, Maybe Version) [ImportedEntry]+ }++windoof :: Maybe (Handle -> IO ())+windoof = Just $ \h -> hSetEncoding h latin1+ >> hSetNewlineMode h universalNewlineMode+++parseDatum :: T.Text -> Day+parseDatum = parseTimeOrError True defaultTimeLocale "%d.%m.%Y" . T.unpack++-- | retrieval function+type Getter a = MyRecord -> a++data CsvImport a = CSV+ { cFilter :: MyRecord -> Bool+ -- ^ should this csv line be processed?+ , cAmount :: Getter T.Text+ -- ^ Amount parsable by 'mamoumtp\''+ , cDate :: Getter Day+ , cVDate :: Getter (Maybe Day)+ , cBank :: a -> Getter T.Text+ , cAccount :: a -> Getter T.Text+ , cHeader :: [T.Text]+ , cBayes :: [T.Text]+ , cDescription :: [T.Text]+ , cVersion :: Version+ , cSeparator :: Char+ }++data CheckedCsvImport a = UnsafeCSV { cRaw :: CsvImport a }+ -- deriving (Show)++toVersionedCSV+ :: SFormat DefaultVersion+ -> [CsvImport a] -> VersionedCSV a+toVersionedCSV format headers = sequence $ (,) format $ fromListUnique $+ (cVersion . cRaw &&& id) . checkRawCSV format <$> headers++type VersionedCSV a = forall m. MonadError Msg m+ => m (SFormat DefaultVersion, M.Map Version (CheckedCsvImport a))+ -- ^ (format with default version, _)++data DefaultVersion = DefaultVersion { fromDefaultVersion :: Version }++checkRawCSV :: SFormat b -> CsvImport a -> CheckedCsvImport a+checkRawCSV format rh =+ if null missing then UnsafeCSV rh+ else error $ printf+ ("format '%s', version '%s': The configured header misses the following "+ ++ "fields required for Bayes or Description:\n%s")+ (fName format) (cVersion rh) $ unlines $ uncurry (printf "%s: %s") <$> missing+ where [head, bayes, desc] = S.fromList . ($rh) <$> [cHeader, cBayes, cDescription]+ missing =+ concatMap (uncurry zip <&> repeat *** (fmap T.unpack . toList . flip S.difference head))+ [("cBayes", bayes), ("cDescription", desc)] :: [(String, String)]+++-- * Pretty Printing++table :: [Int] -- ^ max width+ -> [T.Text] -- ^ Header+ -> [[T.Text]] -- ^ list of cols+ -> P.Box+table w h = table1 . table2 w h+ +table1 :: NonEmpty [P.Box] -- ^ list of rows+ -> P.Box+table1 (header :| rows) = P.punctuateH P.top+ (P.vcat P.top $ replicate (ml P.rows cols2) $ P.text " | ")+ cols2+ where h colHead col = P.vcat P.left $ colHead : sep : col+ where sep = text' $ L.replicate (ml P.cols $ colHead : col) '-'+ ml f = maximum . fmap f+ cols2 = zipWith h header $ transpose rows+ +table2 :: [Int] -- ^ max width+ -> [T.Text] -- ^ Header+ -> [[T.Text]] -- ^ list of cols+ -> NonEmpty [P.Box] -- ^ list of rows+table2 widths header cols =+ toRow <$> (header :| transpose cols)+ where + toRow = g . zipWith asd widths+ asd w = P.para P.left w . T.unpack+ g row = P.alignVert P.top mr <$> row+ where mr = maximum $ P.rows <$> row++mlen :: L.ListLike l e => [l] -> Int+mlen = maximum . fmap L.length++text' :: T.Text -> P.Box+text' = P.text . T.unpack
+ src/Buchhaltung/Import.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++module Buchhaltung.Import+where++import Buchhaltung.Common+import Buchhaltung.Uniques+import Control.Monad.RWS.Strict+import qualified Data.HashMap.Strict as M+import Data.List+import Data.Ord+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.Time.LocalTime+import Hledger.Data+import Hledger.Read+import System.IO+import qualified System.IO.Strict as S+import Text.ParserCombinators.Parsec+import Text.Printf++assertParseEqual' :: (Either ParseError a) -> String+assertParseEqual' = const "a"++-- | convert a batch of importedEntries to Ledger Transactions +fillTxn+ :: (MonadError Msg m, MonadReader (Options User Config env) m) =>+ T.Text -- ^ current time string+ -> ImportedEntry -> m FilledEntry+fillTxn datetime e@(ImportedEntry t (accId, am) source) = do+ tag <- askTag+ todo <- readConfig cTodoAccount+ acc <- lookupErrM "Account not configured" M.lookup accId+ =<< askAccountMap+ let tx = injectSource tag source $ + t{tcomment = "generated by 'buchhaltung' "+ <> datetime <> com (tcomment t)+ ,tpostings =+ [ nullposting{paccount= acc+ ,pamount = amount }+ , nullposting{paccount= todo <> ":" <>+ todoAcc (isNegativeMixedAmount amount)+ ,pamount = missingmixedamt }+ -- leaves amount missing. (alternative: use+ -- balanceTransaction Nothing)+ ]}+ amount = mamountp' $ T.unpack am+ todoAcc Nothing = "Mixed"+ todoAcc (Just False) = "Negative"+ todoAcc (Just True) = "Positive"+ return $ e{ieT = either (const tx) id $ balanceTransaction Nothing tx+ -- try to balance transaction. leave missing amount if+ -- this fails, which should never happen+ , iePostings=()}+ where+ com "" = ""+ com b = " (" <> b <> ")"+++-- | read entries from handle linewise, process and add to ledger+importCat ::+ Maybe FilePath+ -- ^ File to check for already processed transactions+ -> (T.Text -> CommonM env [ImportedEntry])+ -> T.Text+ -> CommonM env Journal+importCat journalPath conv text = do+ oldJ <- liftIO $ maybe (return mempty)+ (fmap (either error id) . readJournalFile Nothing Nothing False)+ journalPath+ datetime <- liftIO $ fshow <$> getZonedTime+ entries <- mapM (fillTxn datetime) =<< conv text + newTxns <- addNew entries oldJ+ liftIO $ hPutStrLn stderr $ printf "found %d new of %d total transactions"+ (length newTxns - length (jtxns oldJ)) $ length entries+ comp <- dateAmountSource <$> askTag+ return oldJ{jtxns = sortBy comp $ ieT <$> newTxns}++dateAmountSource+ :: ImportTag -> Transaction -> Transaction -> Ordering+dateAmountSource tag a b =+ comparing tdate a b + <> comparing (pamount . head . tpostings) a b+ <> comparing (fmap wSource . extractSource tag) a b++importWrite+ :: (T.Text -> CommonM env [ImportedEntry])+ -> T.Text+ -> CommonM env ()+importWrite conv text =do+ journalPath <- absolute =<< readLedger imported+ liftIO . writeJournal journalPath+ =<< importCat (Just journalPath) conv text++importHandleWrite+ :: Importer env -> FullOptions (env, Maybe Version) -> Handle -> ErrorT IO ()+importHandleWrite (Importer chH conv) options handle = do+ text <- liftIO $ do+ maybe (return ()) ($ handle) chH+ liftIO (T.hGetContents handle)+ void $ runRWST (importWrite conv text) options ()+ +importReadWrite+ :: Importer env -> FullOptions (env, Maybe Version) -> FilePath -> ErrorT IO ()+importReadWrite imp opt file =+ withFileM file ReadMode $ importHandleWrite imp opt++ +writeJournal :: FilePath -> Journal -> IO ()+writeJournal journalPath = writeFile journalPath . showTransactions+ ++-- testCat :: Maybe FilePath -- ^ journal+-- -> FilePath -- ^ import+-- -> CustomImport+-- -> Bool -- ^ overwrite+-- -> IO Journal+-- testCat journalPath testfile ci overwrite =+-- withFile testfile ReadMode $ \h -> do+-- j <- importCat def journalPath ci h+-- when overwrite $ maybe mempty (flip writeJournal j) journalPath+-- return j++testRaw _ testfile (f,chH) = withFile testfile ReadMode (\h ->+ maybe (return ()) ($ h) chH >> S.hGetContents h >>= return . show . f)+++-- main = readFile "/tmp/a" >>=+-- addNew "VISA" [] "/home/data/finanzen/jo/bankimport.dat" . lines+
+ src/Buchhaltung/Importers.hs view
@@ -0,0 +1,692 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-unused-binds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# OPTIONS_HADDOCK ignore-exports #-}+module Buchhaltung.Importers+(+ paypalImporter+ , aqbankingImporter+ , comdirectVisaImporter + , module Buchhaltung.Import+ , getBayesFields+ )+where++import Buchhaltung.Common+import Buchhaltung.Import+import Control.Arrow+import Control.Monad.RWS.Strict+import Data.Functor.Identity+import qualified Data.HashMap.Strict as HM+import Data.List+import qualified Data.ListLike as L+import qualified Data.ListLike.String as L+import qualified Data.Map.Strict as M+import Data.Maybe+import Data.Ord+import Data.String+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Data.Text.Lazy as TL+import Data.Time.Calendar+import Formatting (sformat, (%), shown)+import qualified Formatting.ShortFormatters as F+import Text.Parsec+import qualified Text.ParserCombinators.Parsec as C+import Text.Printf++-- * CSV+++-- findVersion+-- :: (MonadError Msg m, Show k, Ord k) => Maybe k -> M.Map k b -> m b+headerInfo+ :: MonadError Msg m =>+ VersionedCSV a -> Maybe Version -> m (SFormat Version, CsvImport a)+headerInfo g v = do+ (format, map) <- g+ let convert rh = (cVersion rh <$ format, rh)+ convert . cRaw <&> lookupErrM+ (printf "Version is not defined for format '%s%'" $ fName format)+ M.lookup (fromMaybe (fromDefaultVersion $ fVersion format) v) map++-- csvImport+-- :: MonadError Msg m+-- => CsvImport+-- -> T.Text -> m [ImportedEntry]+csvImport+ :: (MonadError Msg m+ ,MonadReader (Options user config (a, Maybe Version)) m)+ => VersionedCSV a -> T.Text -> m [ImportedEntry]+csvImport versionedCsv csv = do+ (env, version) <- reader oEnv+ (form, g@CSV{cHeader=expected,+ cDescription = desc,+ cVersion = version }) <- headerInfo versionedCsv version+ let toEntry x = ImportedEntry+ { ieT = genTrans date (vdate =<< cVDate g x)+ (getCsvConcat desc x)+ , ieSource = fromMapToSource form x+ , iePostings = (AccountId (cBank g env $ x) (cAccount g env $ x)+ , cAmount g x)+ }+ where+ vdate vd = if date == vd then Nothing+ else Just vd+ date = cDate g x+ (header, rows) = parseCsv (cSeparator g) . TL.fromStrict $ csv+ if expected == header then+ return $ fmap toEntry $ filter (cFilter g) rows+ else throwError $ L.unlines+ [sformat ("Headers do not match. Expected by format '"%+ F.st%"' version '"%F.st%"':")+ (fName form) version+ ,fshow expected+ ,"Given:"+ ,fshow header+ ]+++-- * AQBanking+--+-- imports output from @aqbankingcli listtrans@++aqbankingImporter :: Importer env+aqbankingImporter = Importer Nothing $ csvImport aqbankingImport++aqbankingImport :: VersionedCSV env+aqbankingImport = toVersionedCSV (SFormat "aqBanking" $ DefaultVersion "4")+ [CSV+ { cFilter = const True+ , cAmount = getCsvConcat [ "value_value"+ , "value_currency"]+ , cDate = readdate . getCsv "date"+ , cVDate = Just . readdate . getCsv "valutadate"+ , cBank = const $ getCsv "localBankCode"+ , cAccount = const $ getCsv "localAccountNumber"+ , cSeparator = ';'+ , cVersion= "4"+ , cHeader = ["transactionId"+ ,"localBankCode"+ ,"localAccountNumber"+ ,"remoteBankCode"+ ,"remoteAccountNumber"+ ,"date"+ ,"valutadate"+ ,"value_value"+ ,"value_currency"+ ,"localName"+ ,"remoteName"+ ,"remoteName1"+ ,"purpose"+ ,"purpose1"+ ,"purpose2"+ ,"purpose3"+ ,"purpose4"+ ,"purpose5"+ ,"purpose6"+ ,"purpose7"+ ,"purpose8"+ ,"purpose9"+ ,"purpose10"+ ,"purpose11"+ ,"category"+ ,"category1"+ ,"category2"+ ,"category3"+ ,"category4"+ ,"category5"+ ,"category6"+ ,"category7"]+ , cDescription = desc+ , cBayes = ["remoteBankCode","remoteAccountNumber"]+ ++ desc+ }]+ where desc = concatMap (\(f,i) -> (f <>) <$> "":i)+ [ ("remoteName", ["1"])+ , ("purpose", fshow <$> [1..11])+ , ("category", fshow <$> [1..7])]+ +-- * Postbank Germany Kontoauszüge (from PDF with @pdftotext@)++-- fromPostbankPDF2 :: T.Text -> [ImportedEntry]+-- fromPostbankPDF2 xx = fmap (f . mconcat) $ groupBy y $ readcsvrow ',' <$> L.lines xx+-- where y a b = head b==""+-- f :: [T.Text] -> ImportedEntry+-- f l@(dat:(_:(des:(am:rest)))) = ImportedEntry{+-- ieT = genTrans (parseDatum $ dat <> "2014") Nothing (L.unwords s)+-- ,ieSource = v $ T.intercalate (v $ T.singleton hbci_sep) l+-- ,iePostings=("Aktiva:Konten:Giro", a <> " EUR")+-- }+-- where s = (c des):rest+-- c = L.unwords . tail . L.words+-- a = mconcat $ L.words $ comma am+-- v r = "\"" <> r <> "\""++-- -- "/home/data/finanzen/imported/daniela_manuell1.csv"+-- fromPostbankPDF1 :: T.Text -> [ImportedEntry]+-- fromPostbankPDF1 xx = fmap (f.concat) $ groupBy y $ readcsvrow ',' <$> L.lines xx+-- where y a b = head b==""+-- f :: [T.Text] -> ImportedEntry+-- f l@(dat:(des:(am:rest))) = ImportedEntry{+-- ieT = genTrans (parseDatum $ dat <> "2013") Nothing (L.unwords s)+-- ,ieSource = v $ T.intercalate (v $ T.singleton hbci_sep) l+-- ,iePostings=("Aktiva:Konten:Giro", a <> " EUR")+-- }+-- where s = (c des):rest+-- c = L.unwords . tail . L.words+-- a = mconcat $ L.words $ comma am+-- v r = "\"" <> r <> "\""++-- * Comdirect Germany++comdirectToAqbanking :: IO ()+comdirectToAqbanking = toAqbanking2 ';' T.getContents comdirect_header comdirect_mapping $ const True+++comdirect_header :: [[Char]]+comdirect_header = ["Buchungstag","Wertstellung (Valuta)","Vorgang","Buchungstext","Umsatz in EUR"]++comdirect_header_visa :: [[Char]]+comdirect_header_visa = ["Buchungstag","Umsatztag","Vorgang","Referenz","Buchungstext","Umsatz in EUR"]++comdirect_mapping_visa :: [([Char], T.Text -> T.Text)]+comdirect_mapping_visa = [+ ("Referenz",const ""),+ ( "Referenz" , undefined),+ ( "Referenz" , const "Visa")+ ] ++ empty 2 ++ [+ ( "Buchungstag", fshow . readdate2),+ ( "Umsatztag", fshow. readdate2),+ ( "Umsatz in EUR", comma ),+ ( "Umsatz in EUR", const "EUR" ),+ ( "Umsatz in EUR", const "Johannes Gerer" ),+ ( "Buchungstext", id),+ ("Referenz",const ""),+ ( "Vorgang",id),+ ( "Referenz",id)] ++ empty (32-14)+ where empty x = take x $ repeat ( "Referenz" , const "")++comdirect_mapping :: [([Char], T.Text -> T.Text)]+comdirect_mapping = [+ ("Buchungstag",const ""),+ ( "Buchungstag" , undefined),+ ( "Buchungstag" , const "Visa")+ ] ++ empty 2 ++ [+ ( "Buchungstag", fshow . readdate2),+ ( "Wertstellung (Valuta)", fshow . readdate2),+ ( "Umsatz in EUR", const "WTF" ),+ ( "Umsatz in EUR", const "EUR" ),+ ( "Umsatz in EUR", const "Johannes Gerer" ),+ ( "Buchungstext", id),+ ( "Vorgang",id)] ++ empty (32-10-2)+ where empty x = take x $ repeat ( "Buchungstag" , const "")++-- comdirectVisaCSVImport :: AccountMap -> T.Text -> [ImportedEntry]+-- comdirectVisaCSVImport accountMappings =+-- aqbankingCsvImport accountMappings . toAqbanking2Pure ';'+-- comdirect_header_visa comdirect_mapping_visa (const True)+-- . T.replace "\n\"Neu\";" "" . L.unlines . ok++ok :: (IsString b, Eq b, L.StringLike b) => b -> [b]+ok = L.takeWhile (/= fromString "")+ . L.dropWhile (/= fromString "\"Buchungstag\";\"Umsatztag\";\"Vorgang\";\"Referenz\";\"Buchungstext\";\"Umsatz in EUR\";")+ . L.lines+++p :: ParsecT [Char] u Identity [Char]+p = do a <- C.manyTill C.anyChar (C.try $ C.string "\n\"Neu\";")+ return a++-- comdirectVisaImporter :: CustomImport2+-- comdirectVisaImporter = Importer windoof comdirectVisaCSVImport+++-- paypalImport :: AccountMap -> T.Text -> [ImportedEntry]+-- paypalImport accountMappings = aqbankingCsvImport accountMappings . myf2 ','+-- paypal_header (paypal_mapping " Brutto" "") filt+-- where filt x = not $ "Storniert" `elem` x+-- myf2 sep header mapping' filtercond =+-- T.intercalate "\n" . show2 . (:) csv_header+-- . map appl . filter filtercond . drop 1 . (readcsv sep)+-- where appl = map (\(a,b) -> a b) . zip transformation . description_list header mapping+-- mapping = map fst mapping'++hbci_sep = ';'++-- | Descriptions create the description, by concatenation of all cols+description+ :: (L.ListLike c item, L.StringLike c, Show a, Eq a) =>+ [a] -> [c] -> c+description cols r = L.unwords . filter (not . L.null) $ description_list csv_header+ cols r++description_list :: (Show a, Eq a) => [a] -> [a] -> [b] -> [b]+description_list t cols r = map fst $ sorted r+ where+ desc_indices = map (idx t) cols -- check if all desired columns exist+ magic v k = do i <- elemIndices k desc_indices+ return (v,i)+ -- for every col in desc_cols get a pair containing the value and+ -- the index in the desc_cols arrays+ sorted r = sortBy (comparing snd) $ mconcat $ zipWith magic r [0..]+ -- extract all desc_cols in the specified order++ -- transformation = map snd mapping'+csv_header = undefined++-- * Comdirect Visa Statements++comdirectVisaImporter :: Importer T.Text+comdirectVisaImporter = Importer windoof $ csvImport comdirectVisa+ +comdirectVisa = toVersionedCSV (SFormat "visa" $ DefaultVersion "manuell")+ [CSV+ { cFilter =(/= "") . getCsv "Buchungstag" + , cAmount = textstrip . comma . (<> " EUR") . getCsv "Ausgang"+ , cDate = parseDatum . getCsv "Buchungstag"+ , cVDate = Just . parseDatum . getCsv "Valuta"+ , cBank = const+ , cAccount = const $ const "Visa"+ , cSeparator = ','+ , cHeader = ["Buchungstag"+ ,"Vorgang"+ ,"Buchungstext"+ ,"Ausgang"+ ,"Valuta"+ ,"Referenz"+ ,"Buchungstext2"+ ]+ , cDescription = desc+ , cBayes = desc+ , cVersion = "manuell"+ -- hand extracted from @pdftotext -layout@+ }+ , CSV+ { cFilter =(/= "") . getCsv "Buchungstag" + , cAmount = comma . (<> " EUR") . getCsv "Umsatz in EUR"+ , cDate = parseDatum . getCsv "Buchungstag"+ , cVDate = Just . parseDatum . getCsv "Umsatztag"+ , cBank = const+ , cAccount = const $ const "Visa"+ , cSeparator = ','+ , cHeader = ["Buchungstag"+ ,"Umsatztag"+ ,"Vorgang"+ ,"Referenz"+ ,"Buchungstext"+ ,"Umsatz in EUR"]+ , cDescription = desc2+ , cBayes = desc2+ , cVersion = "export"+ }+ ]+ where desc = ["Vorgang"+ ,"Buchungstext"+ ,"Buchungstext2"+ ]+ desc2 = ["Vorgang"+ ,"Buchungstext"+ ]+ +-- * Paypal (German)+--+-- understands exports that used the foolowing setting:+--+-- @+-- alle guthaben relevanten Zahlungen (kommagetrennt) ohne warenkorbdetails!+-- @++paypalImporter :: Importer T.Text+paypalImporter = Importer windoof $ csvImport paypalImport++paypalImport :: VersionedCSV T.Text+paypalImport = + let base = CSV+ { cFilter = (/= "Storniert") . getCsv " Status"+ , cAmount = comma . getCsvConcat [ " Netto"+ , " Währung"]+ , cDate = parseDatum . getCsv "Datum"+ , cVDate = const Nothing+ , cBank = const $ const "Paypal"+ , cAccount = const+ , cSeparator = ','+ , cVersion = "undefined"+ , cHeader = []+ , cBayes = ["undefined"]+ , cDescription = ["undefined"]+ } in toVersionedCSV (SFormat "paypal" $ DefaultVersion "2016")+ [base { cVersion = "2016"+ , cHeader = ["Datum"+ ," Zeit"+ ," Zeitzone"+ ," Name"+ ," Typ"+ ," Status"+ ," W\228hrung"+ ," Brutto"+ ," Geb\252hr"+ ," Netto"+ ," Von E-Mail-Adresse"+ ," An E-Mail-Adresse"+ ," Transactionscode"+ ," Status der Gegenpartei"+ ," Adressstatus"+ ," Artikelbezeichnung"+ ," Artikelnummer"+ ," Betrag f\252r Versandkosten"+ ," Versicherungsbetrag"+ ," Umsatzsteuer"+ ," Option 1 - Name"+ ," Option 1 - Wert"+ ," Option 2 - Name"+ ," Option 2 - Wert"+ ," Auktions-Site"+ ," K\228ufer-ID"+ ," Artikel-URL"+ ," Angebotsende"+ ," Vorgangs-Nr."+ ," Rechnungs-Nr."+ ," Txn-Referenzkennung"+ ," Rechnungsnummer"+ ," Individuelle Nummer"+ ," Belegnummer"+ ," Guthaben"+ ," Adresszeile 1"+ ," Zus\228tzliche Angaben"+ ," Ort"+ ," Staat/Provinz/Region/Landkreis/Territorium/Pr\228fektur/Republik"+ ," PLZ"+ ," Land"+ ," Telefonnummer"+ ," "]+ , cBayes = [" Name"+ ," An E-Mail-Adresse"+ ," Von E-Mail-Adresse"+ ," Artikelbezeichnung"+ ," Typ"+ ," Status"+ ," Käufer-ID"+ , " Status der Gegenpartei"," Adressstatus"+ , " Option 1 - Name"+ , " Option 2 - Name"+ ," Auktions-Site"+ ," K\228ufer-ID"+ ," Artikel-URL"+ ," Adresszeile 1"+ ," Zus\228tzliche Angaben"+ ," Ort"+ ," Staat/Provinz/Region/Landkreis/Territorium/Pr\228fektur/Republik"+ ," PLZ"+ ," Land"+ ," Telefonnummer"+ ]+ , cDescription = [" Name"+ ," Artikelbezeichnung"+ ," Typ"+ ," Zeit"]+ }+ ,base { cVersion = "2014"+ , cHeader = ["Datum"+ ," Zeit"+ ," Zeitzone"+ ," Name"+ ," Art"+ ," Status"+ ," W\228hrung"+ ," Brutto"+ ," Geb\252hr"+ ," Netto"+ ," Von E-Mail-Adresse"+ ," An E-Mail-Adresse"+ ," Transaktionscode"+ ," Status der Gegenpartei"+ ," Adressstatus"+ ," Verwendungszweck"+ ," Artikelnummer"+ ," Betrag f\252r Versandkosten"+ ," Versicherungsbetrag"+ ," Umsatzsteuer"+ ," Option 1 - Name"+ ," Option 1 - Wert"+ ," Option 2 - Name"+ ," Option 2 - Wert"+ ," Auktions-Site"+ ," K\228ufer-ID"+ ," Artikel-URL"+ ," Angebotsende"+ ," Vorgangs-Nr."+ ," Rechnungs-Nr."+ ," Txn-Referenzkennung"+ ," Rechnungsnummer"+ ," Individuelle Nummer"+ ," Best\228tigungsnummer"+ ," Guthaben"+ ," Adresse"+ ," Zus\228tzliche Angaben"+ ," Ort"+ ," Staat/Provinz/Region/Landkreis/Territorium/Pr\228fektur/Republik"+ ," PLZ"+ ," Land"+ ," Telefonnummer der Kontaktperson"+ ," "]+ , cBayes = [" Name"+ ," An E-Mail-Adresse"+ ," Von E-Mail-Adresse"+ ," Verwendungszweck"+ ," Art"+ ," Status"+ ," Käufer-ID"+ , " Status der Gegenpartei"," Adressstatus"+ , " Option 1 - Name"+ , " Option 2 - Name"+ ," Auktions-Site"+ ," K\228ufer-ID"+ ," Artikel-URL"+ ," Adresse"+ ," Zus\228tzliche Angaben"+ ," Ort"+ ," Staat/Provinz/Region/Landkreis/Territorium/Pr\228fektur/Republik"+ ," PLZ"+ ," Land"+ ," Telefonnummer der Kontaktperson"+ ]+ , cDescription = [" Name"+ ," Verwendungszweck"+ ," Art"+ ," Zeit"]+ }+ , base { cVersion = "2013"+ , cHeader = ["Datum"+ ," Zeit"+ ," Zeitzone"+ ," Name"+ ," Art"+ ," Status"+ ," W\228hrung"+ ," Brutto"+ ," Geb\252hr"+ ," Netto"+ ," Von E-Mail-Adresse"+ ," An E-Mail-Adresse"+ ," Transaktionscode"+ ," Status der Gegenpartei"+ ," Adressstatus"+ ," Verwendungszweck"+ ," Artikelnummer"+ ," Betrag f\252r Versandkosten"+ ," Versicherungsbetrag"+ ," Umsatzsteuer"+ ," Option 1 - Name"+ ," Option 1 - Wert"+ ," Option 2 - Name"+ ," Option 2 - Wert"+ ," Auktions-Site"+ ," K\228ufer-ID"+ ," Artikel-URL"+ ," Angebotsende"+ ," Vorgangs-Nr."+ ," Rechnungs-Nr."+ ," Txn-Referenzkennung"+ ," Rechnungsnummer"+ ," Individuelle Nummer"+ ," Menge"+ ," Best\228tigungsnummer"+ ," Guthaben"+ ," Adresse"+ ," Zus\228tzliche Angaben"+ ," Ort"+ ," Staat/Provinz/Region/Landkreis/Territorium/Pr\228fektur/Republik"+ ," PLZ"+ ," Land"+ ," Telefonnummer der Kontaktperson"+ ," "]+ , cBayes = [" Name"+ ," An E-Mail-Adresse"+ ," Von E-Mail-Adresse"+ ," Verwendungszweck"+ ," Art"+ ," Status"+ ," Käufer-ID"+ ," Status der Gegenpartei"," Adressstatus"+ ," Option 1 - Name"+ ," Option 2 - Name"+ ," Auktions-Site"+ ," K\228ufer-ID"+ ," Artikel-URL"+ ," Adresse"+ ," Zus\228tzliche Angaben"+ ," Ort"+ ," Staat/Provinz/Region/Landkreis/Territorium/Pr\228fektur/Republik"+ ," PLZ"+ ," Land"+ ," Telefonnummer der Kontaktperson"+ ]+ , cDescription = [" Name"+ ," Verwendungszweck"+ ," Art"+ ," Zeit"]+ }]++-- * other stuff+++show2 :: [[T.Text]] -> [T.Text]+show2 = map (T.intercalate ";" . map (\x -> "\"" <> (quote x) <> "\""))+ where quote x = T.replace "\"" escapedDoubleQuotes x++hibiscusToAqbanking :: IO ()+hibiscusToAqbanking = toAqbanking ';'+ (T.readFile "/home/data/finanzen/imported/hibiscus-export-20120930.csv")+ hibicus_header hibiscus_mapping hibiscus_transf $ const True++toAqbankingPure+ :: (Show a, Eq a) =>+ Char+ -> [a]+ -> [a]+ -> [T.Text -> T.Text]+ -> ([T.Text] -> Bool)+ -> T.Text+ -> T.Text+toAqbankingPure sep header mapping transformation filtercond =+ T.intercalate "\n" . show2 . (:) csv_header+ . map appl . filter filtercond . drop 1 . (readcsv sep)+ where appl = map (\(a,b) -> a b) . zip transformation . description_list header mapping++toAqbanking+ :: (Show a, Eq a) =>+ Char+ -> IO T.Text+ -> [a]+ -> [a]+ -> [T.Text -> T.Text]+ -> ([T.Text] -> Bool)+ -> IO ()+toAqbanking sep f header mapping transf filt =+ T.putStr =<< toAqbankingPure sep header mapping transf filt <$> f++toAqbanking2Pure+ :: (Show a, Eq a) =>+ Char+ -> [a]+ -> [(a, T.Text -> T.Text)]+ -> ([T.Text] -> Bool)+ -> T.Text+ -> T.Text+toAqbanking2Pure sep header mapping filt = toAqbankingPure sep header mapping' transf filt+ where mapping' = map fst mapping+ transf = map snd mapping++toAqbanking2 sep f header mapping filt =+ T.writeFile "/tmp/new" =<< toAqbanking2Pure sep header mapping filt <$> f++hibicus_header :: [[Char]]+hibicus_header =["Kontonummer","BLZ","Konto","Gegenkonto","Gegenkonto BLZ","Gegenkonto Inhaber","Betrag","Valuta","Datum","Verwendungszweck","Verwendungszweck 2","Zwischensumme","Primanota","Kundenreferenz","Kategorie","Kommentar","Weitere Verwendungszwecke"]++hibiscus_mapping :: [[Char]]+hibiscus_mapping = ["Primanota","BLZ","Kontonummer","Gegenkonto BLZ","Gegenkonto","Datum","Valuta","Betrag" , "Betrag" , "Betrag" , "Gegenkonto Inhaber", "Betrag", "Verwendungszweck","Verwendungszweck 2","Kommentar","Weitere Verwendungszwecke"] ++ (take 16 $ repeat "Betrag")++hibiscus_transf :: [T.Text -> T.Text]+hibiscus_transf = [id, id , id , id , id , fshow . readdate2, fshow . readdate2,comma ,const "EUR", const "Johannes Gerer", id , const ""] <> (take 4 $ repeat id) <> (take 16 $ repeat $ const "") :: [T.Text -> T.Text]++comma :: T.Text -> T.Text+comma = T.replace "," "." . T.replace "." "" :: T.Text -> T.Text++readdate2 :: Stream t Data.Functor.Identity.Identity Char+ => t -> Date2+readdate2 s = either (error.show) id (parse p_date2 "date" s)++p_date2 :: Stream t Data.Functor.Identity.Identity Char+ => Parsec t () Date2+p_date2 = do d <- many1 digit+ char '.'+ m <- many1 digit+ char '.'+ y <- many1 digit+ return (D y m d)++readdate :: T.Text -> Day+readdate s = either (error.show) id (parse p_date "date" s)++p_date :: Stream t Data.Functor.Identity.Identity Char+ => Parsec t () Day+p_date = do y <- many1 digit+ char '/'+ m <- many1 digit+ char '/'+ d <- many1 digit+ return $ fromGregorian (read y) (read m) (read d)++instance Show Date2 where+ show (D y m d) = concat [y, "/", m, "/", d]++data Date2 = D String String String -- year month day+ deriving (Eq)+++toBayes+ :: MonadError Msg m+ => VersionedCSV a+ -> m (SFormat DefaultVersion, M.Map Version [T.Text])+toBayes = fmap (second $ fmap $ cBayes . cRaw)+ +defaultFields+ :: MonadError Msg m =>+ m (M.Map (SFormat ()) (M.Map Version [T.Text]))+defaultFields = fromListUnique . fmap (first $ (() <$))+ =<< sequence [toBayes paypalImport, toBayes aqbankingImport]++getBayesFields+ :: MonadError Msg m+ => Source -> m [T.Text]+getBayesFields source = do+ fields <- lookupErrM "Version has to be configured" M.lookup+ (fVersion format)+ =<< lookupErrM "Format has to be configured" M.lookup+ (() <$ format)+ =<< defaultFields+ return $ mapMaybe (flip M.lookup $ sStore source) fields+ where format = sFormat source
+ src/Buchhaltung/Match.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_HADDOCK ignore-exports #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+module Buchhaltung.Match+where++import Buchhaltung.Ask+import Buchhaltung.Common+import Buchhaltung.Importers+import Buchhaltung.Zipper+import Control.Arrow+import Control.Concurrent.Async+import Control.Lens+import Control.Monad.RWS+import Control.Monad.Reader+import Data.Either+import Data.Function+import Data.List+import qualified Data.List.NonEmpty as N+import qualified Data.ListLike as L+import qualified Data.ListLike.String as L+import qualified Data.Map.Strict as M+import Data.Maybe+import Data.Ord+import qualified Data.Semigroup as S+import qualified Data.Set as S+import qualified Data.Text as T+import Hledger.Data hiding (at)+import System.Console.Haskeline+import System.Exit+import System.FilePath+import System.Process+import qualified Text.PrettyPrint.Boxes as P+import Text.Printf+ +type MatchT m = RWST (FullOptions FilePath) ()+ (S.Set AccountName, Zipper Update) (ErrorT m)+ -- ^ R: temporaray dbacl path+ --+ -- W: Set of learned accounts+ -- + -- S: Zipper with all transaction that neede to be matched++match :: FullOptions FilePath -> Journal -> ErrorT IO ()+match options j = maybe (liftIO $ print "No unmatched transactions")+ g+ $ runReader (groupByAccount j) options+ where+ g (done, todos) = void $ runRWST (learn done >> mainLoop "")+ options+ (S.fromList $ fst <$> done, differentiate todos) :: ErrorT IO ()++-- | Apply the first matching 'Todo'+updateAccountName :: Update -> Maybe (Transaction, Transaction)+updateAccountName WithSource{ wInfo = Nothing } = Nothing+updateAccountName up =+ Just (wTx up, tPosts . ix (wIdx up) . pAcc .~ (fromJust $ wInfo up) $ wTx up)++printSource :: Source -> String+printSource = P.render . table [25,35] ["Field", "Value"] .+ (\(x,z) -> [x,z]) . unzip . M.toList . sourceToMap++mainLoop :: String -> MatchT IO ()+mainLoop i = do+ zip <- gets $ snd+ let tx = present zip+ liftIO $ do+ putStrLn $ printSource $ wSource $ tx+ printf "Current Transaction: %d, Remaining: %d\n"+ (length $ past zip )+ $ length $ future zip+ putStr i+ account <- myAskAccount =<< suggestAccount tx -- + let+ g "save" = void $ saveChanges $ changeTransaction+ $ mapMaybe updateAccountName $ integrate zip+ g "<" = prev zip+ g ">" = next zip+ g _ = do+ modify $ first $ S.insert account+ learn [(account, return tx)]+ modify $ second $ fwd . modifyPresent (fmap $ const $ Just account)+ next zip+ g account+ where+ next (LZ _ []) = mainLoop "<< DONE! Use 'save' to exit >>\n\n"+ next z = modify (second $ const fwd z) >> mainLoop ""+ prev (LZ (_ :| []) _) =+ mainLoop "<< This is the first transaction >>\n\n"+ prev z = modify (second $ const back z) >> mainLoop ""++histfsuf :: String+histfsuf = "learn"++data Default = Default { display :: T.Text, defAcc :: AccountName }+ +suggestAccount :: Update -> MatchT IO (Maybe Default)+suggestAccount tx = do+ accs <- getAccountList+ args <- dbaclProcC <$> mapM tmp accs+ text <- bayesLine tx+ bin <- readConfig cDbaclExecutable+ let+ g [] = return Nothing+ g accounts = do+ (code, output, _) <- liftIO $ readProcessWithExitCode bin args text+ case code of+ ExitSuccess -> return Nothing+ ExitFailure x ->+ return $ Just $ Default info sa+ where sa = accounts !! (x-1)+ info :: T.Text+ info = either fshow (text . lookup sa)+ (dbacl_parse accs output)+ text Nothing = "failed\t\t"+ text (Just te) = "uncertainty: " <> T.pack te <> "\t"+ maybe (g accs) (return . Just . Default "manual:\t\t\t") $ wInfo tx+ +bayesLine :: Monad m => WithSource a -> MatchT m String+bayesLine w = T.unpack . T.unwords <$> getBayesFields (wSource w)++learn :: [(AccountName, NonEmpty (WithSource a))]+ -> MatchT IO ()+learn pairs = liftIO . runConcurrently . mconcat =<< mapM learn' pairs+ where learn' (name,txs) = do + bin <- readConfig cDbaclExecutable+ text <- L.unlines <$> mapM bayesLine (N.toList txs)+ file <- tmp name+ return $ Concurrently $ do+ -- let text = if text'=="" then "\n" else text' PROBLEM-bayes_fields+ L.putStrLn $ "Learning: " <> name+ -- putStrLn $ "\n\n"++ (intercalate "\n\n" $ info <$> todos)+ -- putStrLn text+ out <- readProcess bin (dbaclProc file) text+ appendFile (file <> "_raw" ) $ text <> "\n\n" <> out+ L.putStrLn $ "Done: " <> name++accountCompletion :: [String] -> CompletionFunc IO+accountCompletion cc = completeWord Nothing+ "" -- don't break words on whitespace, since account names+ -- can contain spaces.+ $ \s -> return $ map (\x -> Completion x x False)+ $ filter (s `isInfixOf`) cc++type Update = WithSource (Maybe AccountName)++-- | Group all transactions with source into those that already have+-- an account and those that starting with 'cTodoAccount'+groupByAccount+ :: MonadReader (Options user Config env) m =>+ Journal+ -> m (Maybe ( [(AccountName, NonEmpty (WithSource ()))]+ , NonEmpty (WithSource (Maybe a))))+groupByAccount j = do+ tag <- askTag+ todoFilt <- askTodoFilter+ let acc = paccount . wPosting+ f s = if todoFilt ac then Right $ fmap (const Nothing) <$> s+ else Left (ac, s)+ where ac = acc $ N.head s+ return $ traverse (fmap S.sconcat . nonEmpty) $ partitionEithers $ fmap f+ $ N.groupBy ((==) `on` acc)+ $ sortBy (comparing acc) $ rights $ extractSource tag+ <$> jtxns j ++myAskAccount :: Maybe Default -> MatchT IO AccountName+myAskAccount acc = getAccountList >>= \accs -> + liftIO $ askAccount accs (defAcc <$> acc) (Just histfsuf) prompt+ where prompt = Right $ maybe "" showdef acc <> "\n[<, >, save, RET]:\t"+ showdef (Default d a) = d <> (revAccount2 a) :: T.Text++getAccountList :: Monad m => MatchT m [AccountName]+getAccountList = gets $ S.toList . fst++tmp :: Monad m => T.Text -> MatchT m FilePath+tmp name = reader $ (</> T.unpack name) . oEnv ++-- * dbacl arguments++-- | learning+dbaclProc :: String -> [String]+dbaclProc x = [ "-g" , oneword+ , "-g" , twowords+ --,"-D" -- interessant "-D" zeigt welche features gefunden wurden (use grep match)+ , "-d"+ -- ,"-w 1" -- use N-grams with N=2+ -- "-S" -- ignore line breaks+ , "-0" -- do not preload (this is done by -o)+ -- ,"-e", "alnum" -- alpha numeric+ , "-j" -- lowercase+ , "-l", x+ , "-o", x ++ "_online"+ ] -- category name+ where word = "(^|[^[:alpha:]])([[:alpha:]]{3,})"+ oneword = wrap $ word ++"||2"+ twowords = wrap $ word++"[^[:alpha:]]+"++word++"||24"+ wrap = id --x = "'"++x++"'"++-- | classification +dbaclProcC :: [String] -> [String]+dbaclProcC cats = let cats' = concat $ sequence [["-c"],cats]+ in ( cats' ++ [ -- search this file for 'debugging'+ -- "-v" -- output name of best (dont know when useful)+ "-n" -- neg. logaritm+ -- , "-N" -- prob+ -- ,"-X"+ -- ,"-d" -- sehr hilfreich, see manual (aber nur mit weniger categorien+ ] )++
+ src/Buchhaltung/OptionParsers.hs view
@@ -0,0 +1,162 @@+module Buchhaltung.OptionParsers where++import Buchhaltung.Common+import Control.Exception+import Control.Monad.RWS.Strict+import Data.Maybe+import Data.Foldable+import qualified Data.Text as T+import Options.Applicative+import System.Directory+import System.Environment+import System.FilePath+import qualified Text.PrettyPrint.ANSI.Leijen as D+import Text.Printf++++-- * Option parsers+--+-- https://hackage.haskell.org/package/optparse-applicative/docs/Options-Applicative-Builder.html++mainParser = do+ env <- getEnvironment+ home <- try getHomeDirectory :: IO (Either SomeException FilePath)+ return $ info+ ( helper *> (Options+ <$> userP+ <*> profile env home+ <*> subparser commands+ <*> pure ()+ <*> pure ()+ )+ ) mempty++paragraph = foldr ((D.</>) . D.text) mempty . words++userP :: Parser (Maybe Username)+userP = optional $ (Username . T.pack) <&> strOption $ long "user"+ <> short 'u' <> metavar "USER"+ <> helpDoc+ (Just $ paragraph "Select the user. Default: first configured user")++envVar = "BUCHHALTUNG"++-- | optparse profile folder+profile+ :: Exception b =>+ [(String, FilePath)] -> Either b FilePath -> Parser FilePath+profile env home = strOption $+ long "profile"+ <> value (fromMaybe (either throw buch home) envBuch)+ <> short 'p'+ <> metavar "FOLDER"+ <> helpDoc (Just $+ paragraph "path to the profile folder. Precedence (highest to lowerst):"+ D.<$> D.text "1. this command line option"+ D.<$> paragraph (printf "2. Environment option: \"%s\" %s" envVar $+ (maybe "(not set)" (printf "= '%s'") envBuch :: String ))+ D.<$> paragraph (printf "3. %s %s" (buch "~") $+ either (const "(home dir not available)")+ (("= " ++) . buch) home)+ )+ where buch = (</> ".buchhaltung")+ envBuch = lookup envVar env++versionP :: Parser (Maybe T.Text)+versionP = optional . fmap T.pack+ $ strOption $ long "version"+ <> short 'v' <> metavar "VERSION"++-- | optparse command parser+-- commands :: Parser Action+commands :: Mod CommandFields Action+commands =+ command' "add"+ (Add . fmap (Username . T.pack) <$> many+ (strOption (short 'w' <> help "with partner USERNAME"+ <> long "with"+ <> metavar "USERNAME")))+ (progDesc "manual entry of new transactions")++ <> command' "import"+ (Import <$> versionP+ <*> strArgument (metavar "FILENAME")+ <*> subparser importOpts)+ (progDesc "import transactions from FILENAME")++ <> command' "update"+ (Update <$> versionP+ <*> (switch $ short 'm' <> long "match" <> help "run match after import")+ <*> (fmap not $ switch $ short 'n' <> long "no-fetch"+ <> help "do not fetch new transactions"))+ (progDesc+ "fetch and import AQ Banking transactions (using \"aqbanking request\" and \"listtrans\")")++ <> command' "match" (pure Match)+ (progDesc "manual entry of new transactions")++ <> command' "lb" (pure ListBalances)+ (progDesc "list balances of all AQBanking accounts (only available after 'update')")++ <> command' "setup" (pure Setup)+ (progDesc "initial setup of AQBanking")++ -- todo: pass through, that only sets env var and runs remaining args as "command args"++ <> passThrough Commit "commit" (Just "c") (Just $ concat+ ["run git commit in the dir of the user's mainLedger file and pass all "+ ,"following arguments to git. "+ ,"The Message will contain all AQBalances "+ ,"and the Ledger balance sheet"])++ <> passThrough Ledger "ledger" (Just "l") Nothing++ <> passThrough HLedger "hledger" (Just "hl") Nothing++ <> passThrough AQBanking "aqbanking" (Just "aq") Nothing++passThrough+ :: ([String] -> Action)+ -> String -- ^ command+ -> Maybe String -- ^ Short version+ -> Maybe String -- ^ Message+ -> Mod CommandFields Action+passThrough constr long short desc = mconcat $ f <$> long : toList short+ where f cmdName = command' cmdName+ (constr <&> many $ strArgument mempty)+ $ noIntersperse+ <> (progDesc $ fromMaybe+ ("pass args through to '" ++ long ++ "'") desc)++command' :: String -> Parser a -> InfoMod a -> Mod CommandFields a+command' str parser infomod =+ command str $ info (helper *> parser) infomod++importOpts :: Mod CommandFields ImportAction+importOpts =+ metavar "FORMAT"+ <>+ commandGroup "Available FORMATS"+ <>+ command' "comdirectVisa"+ (ComdirectVisa . T.pack <$> strArgument+ (metavar "BLZ"))+ (progDesc $ concat ["import from german Comdirect Visa Statements. "+ ,"versions: manuell, export"])++ <>+ command' "paypal"+ (Paypal . T.pack <$> strArgument+ (help "paypal username (as configured in 'bankAccounts')"+ <> metavar "PAYPAL_USERNAME"))+ (progDesc $ concat ["import from german Paypal CSV export with "+ ,"\"alle guthaben relevanten Zahlungen "+ ,"(kommagetrennt) ohne warenkorbdetails\". "+ ,"versions: 2013, 2014, 2016"])++ <> command' "aqbanking"+ (pure AQBankingImport)+ (progDesc $ concat ["import CSV file generated by "+ ,"\"aqbankingcli listtrans\". "+ ,"versions: 4"])
+ src/Buchhaltung/Types.hs view
@@ -0,0 +1,476 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE CPP #-}+#define DERIVING Generic, Default, Show, FromJSON+module Buchhaltung.Types+ (module Control.Monad.Except+ ,module Buchhaltung.Types+ )where++import Buchhaltung.Utils+import Control.Applicative+import Control.Arrow+import Control.DeepSeq+import Control.Monad.Except+import Control.Monad.Identity+import Control.Monad.RWS.Strict+import Control.Monad.Reader+import qualified Data.Aeson as A+import qualified Data.Aeson.Text as A+import qualified Data.Aeson.Types as A+import Data.Char+import Data.Default+import Data.Foldable+import Data.Function+import Data.Functor+import qualified Data.HashMap.Strict as HM+import Data.Hashable+import qualified Data.ListLike as L+import qualified Data.Map.Strict as M+import Data.Maybe+import Data.String+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Vector as V+import Data.Yaml+import Formatting+import Formatting.Internal (Format)+import qualified Formatting.ShortFormatters as F+import GHC.Generics+import Hledger.Data+import Prelude hiding (lookup)+import System.FilePath+import Text.Printf+import qualified Text.Regex.TDFA as R+import Text.Regex.TDFA.Text ()++-- * Monad used for most of the funtionality++type CommonM env = RWST (FullOptions env) () () (ErrorT IO)++-- * The Source of an imported transaction++type Version = T.Text++data SFormat a = SFormat { fName :: T.Text+ , fVersion :: a+ }+ deriving (Generic, Show, Eq, Ord, Read, Hashable, Functor)++-- | represents a key value store and a protocol+data Source = Source { sFormat :: SFormat Version+ , sStore :: M.Map T.Text T.Text }+ deriving (Generic, Show, Eq, Ord, Read)+++-- | Creates a 'Source' from non null values of a HashMap (e.g. from+-- 'MyRecord')+fromMapToSource :: SFormat Version -> HM.HashMap T.Text T.Text -> Source+fromMapToSource format = Source format . M.fromList .+ filter (not . L.null . snd) . HM.toList++-- | produces a map that includes 'sFormat' under the keys @"formatName"@+-- and @"formatVersion"@+sourceToMap :: Source -> M.Map T.Text T.Text+sourceToMap s = M.unionWith (\x y -> x <> ", " <> y)+ (sStore s)+ $ M.fromList $ formatToAssoc $ sFormat s++formatToAssoc f = [("formatName", fName f)+ ,("formatVersion", fVersion f)]++json :: Source -> TL.Text+json = A.encodeToLazyText++instance FromJSON Source where+ parseJSON (Object v) = do+ Source <$>+ (SFormat <$> v .: "name" <*> v .: "version")+ <*> v.: "store"++instance ToJSON Source where+ toJSON s = Object $ HM.insert "store" (toJSON $ sStore s) $ toJSON+ <$> HM.fromList (formatToAssoc $ sFormat s)++stripPrefixOptions n = A.defaultOptions{A.fieldLabelModifier = g}+ where g = drop n . fmap toLower++-- * Import Tag+++newtype ImportTag = ImportTag { fromImportTag :: T.Text }+ deriving ( Generic, Show)++instance Default ImportTag where+ def = "SOURCE"++instance IsString ImportTag where+ fromString = ImportTag . fromString++-- * Error handling++type Msg = T.Text+type Error = Either Msg+type ErrorT = ExceptT Msg++throwFormat+ :: MonadError Msg m => Format T.Text t -> (t -> Msg) -> m b+throwFormat msg a = throwError $ a $ sformat msg++maybeThrow+ :: MonadError Msg m => Format T.Text t+ -> (t -> Msg) -> (a1 -> m b) -> Maybe a1 -> m b+maybeThrow msg a = maybe (throwFormat msg a)+++lookupErrD+ :: Show t => [Char] -- ^ additional description+ -> (t -> t1 -> Maybe a) -- ^ lookup function+ -> t -- ^ lookup arg2+ -> t1 -- ^ lookup arg2+ -> a+lookupErrD d l k m =+ either (error . T.unpack) id $ runExcept $ lookupErrM d l k m+++lookupErrM+ :: (MonadError Msg m, Show a) =>+ String -> (a -> t -> Maybe b) -> a -> t -> m b+lookupErrM description lookup k container =+ maybeThrow ("lookupErr: " %F.sh% " not found: " %F.s)+ (\f -> f k description) return+ $ lookup k container+++fromListUnique :: (MonadError Msg m, Show k, Ord k)+ => [(k, a)] -> m (M.Map k a)+fromListUnique = sequence . M.fromListWithKey+ (\k a b -> throwFormat ("Duplicate key '"%shown%"' in M.fromList") ($ k))+ . fmap (second pure)++-- * Options++data Options user config env = Options+ { oUser :: user+ , oProfile :: FilePath+ , oAction :: Action+ , oConfig :: config+ , oEnv :: env+ }+ deriving (Show, Generic, NFData)++type FullOptions = Options User Config+type RawOptions = Options (Maybe Username) ()++toFull :: MonadError Msg m+ => RawOptions env+ -> Config+ -> m (FullOptions env)+toFull opts1@Options{oUser=user} config =+ (\u -> opts2{oUser = u}) <$>+ runReaderT (maybe (defaultUser 0) lookupUser user) opts2+ where opts2 = opts1 { oConfig = config }++-- ** Reading options++readConfig :: MonadReader (Options user config env) m => (config -> a) -> m a+readConfig f = reader $ f. oConfig++readUser :: MonadReader (Options user config env) m => (user -> a) -> m a+readUser f = reader $ f . oUser++user :: MonadReader (Options user config env) m => m user+user = readUser id++readLedger+ :: MonadReader (Options User config env) m =>+ (Ledgers -> FilePath) -> m FilePath+readLedger = (<$> readUser ledgers)++-- | get absolute paths in profile dir+absolute+ :: MonadReader (Options user config env) m =>+ FilePath -> m FilePath+absolute f = do prof <- reader oProfile+ return $ prof </> f+++-- * Config++data Config = Config+ {+ cUsers :: Users+ , cUserList :: V.Vector Username+ , cImportTag :: ImportTag+ , cTodoAccount :: AccountName+ -- ^ account for unmatched imported transactions+ , cDbaclExecutable :: FilePath+ , cLedgerExecutable :: FilePath+ , cHledgerExecutable :: FilePath+ -- , cFormats :: HM.HashMap T.Text [T.Text]+ -- -- ^ for every format a list of columns used in the bayesian+ -- -- classifier used in match+ }+ deriving ( Generic, Show )++askTag :: MonadReader (Options user Config env) m => m ImportTag+askTag = readConfig $ cImportTag++askTodoFilter :: MonadReader (Options user Config env) m+ => m (AccountName -> Bool)+askTodoFilter = return . L.isPrefixOf =<< readConfig cTodoAccount++instance FromJSON Config where+ parseJSON (Object v) = do+ -- Users are configured as list, to have a defined order+ users <- parseJSON =<< v .: "users" :: A.Parser (V.Vector User)+ -- formats <- v .:? "formats" .!= mempty+ dbEx <- v .:? "dbaclExecutable" .!= "dbacl" :: Parser FilePath+ [lEx, hlEx] <- forM ["", "h"] $ \pfx ->+ v .:? (T.pack pfx <> "ledgerExecutable") .!= (pfx <> "ledger")+ :: Parser FilePath+ return Config+ { cUsers = HM.fromList $ (\u -> (name u, u)) <$> V.toList users+ , cUserList = name <$> users+ , cImportTag = def+ , cTodoAccount = "TODO"+ -- , cFormats = formats+ , cDbaclExecutable = dbEx+ , cLedgerExecutable = lEx+ , cHledgerExecutable = hlEx+ }++ parseJSON invalid = A.typeMismatch "Config" invalid++readConfigFromFile :: FilePath -> IO Config+readConfigFromFile path = either (error . prettyPrintParseException) id <$>+ decodeFileEither (path </> "config" <.> "yml") :: IO Config+++-- * User++data User = User+ { name :: Username+ , ledgers :: Ledgers+ , accountPrefixOthers :: Maybe AccountName+ -- ^ the account prefix for accounts receivable or payable+ -- (depending on current balance) to other users+ , aqBanking :: Maybe AQBankingConf+ , bankAccounts :: Maybe BankAccounts+ , ignoredAccountsOnAdd :: Maybe [Regex]+ , numSuggestedAccounts :: Maybe Int+ }+ deriving ( Generic, Show, FromJSON )++type Users = HM.HashMap Username User++newtype Username = Username T.Text+ deriving ( Generic, FromJSON, NFData, Eq, Hashable, A.FromJSONKey)++fromUsername :: Username -> T.Text+fromUsername (Username n) = n++instance Show Username where+ show = T.unpack . fromUsername++instance Eq User where+ (==) = (==) `on` name++-- ** Reading User settings++-- | Looks up a user and throws an error if they do not exist.+lookupUser :: ( MonadError Msg m+ , MonadReader (Options user Config e) m)+ => Username+ -> m User+lookupUser user = do+ maybeThrow msg ($ user) return . HM.lookup user . cUsers =<< reader oConfig+ where msg = "User '"%F.sh%"' not found"++defaultUser :: ( MonadError Msg m+ , MonadReader (Options user Config e) m)+ => Int -- ^ default position in user list+ -> m User+defaultUser ix = do+ config <- reader oConfig+ maybeThrow msg ($ succ ix) lookupUser $ cUserList config V.!? ix+ where msg = "There are less than "%F.d%+ " users configured. Please add a user to the config file."++-- ** A User's ledger files++data Ledgers = Ledgers+ { imported :: FilePath+ , addedByThisUser :: FilePath+ , addedByOthers :: Maybe FilePath+ , mainLedger :: FilePath -- ^ ledger file for 'ledger' CLI+ , mainHledger :: Maybe FilePath -- ^ ledger file for 'hledger' CLI+ }+ deriving (Generic, Default, Show, FromJSON)++-- | generates the receiable/payable account for between two users+-- (suffixed by the current, the recording, user)+receivablePayable+ :: (MonadError Msg m, MonadReader (FullOptions env) m)+ => Bool+ -- ^ TRUE | FALSE = for (this | the other) user's ledger+ -> User -- ^ the other user+ -> m T.Text+receivablePayable forThis other = do+ this <- readUser id+ let (ledgerU, accountU) =+ if forThis then (this, other) else (other, this)+ let full pref = return $ intercalateL ":" $ pref :+ (fromUsername . name <$> [accountU, this])+ maybeThrow msg ($ name ledgerU) full+ $ accountPrefixOthers ledgerU+ where msg = "User '"%F.sh%"' has no accountPrefixOthers configured"++-- ** A user's bank accounts++askAccountMap :: MonadReader (Options User config env) m => m AccountMap+askAccountMap = readUser $ maybe mempty fromBankAccounts . bankAccounts+++newtype BankAccounts = BankAccounts AccountMap+ deriving (Generic, Default, Show)+++fromBankAccounts :: BankAccounts -> AccountMap+fromBankAccounts (BankAccounts b) = b++isIgnored :: User -> AccountName -> Bool+isIgnored user acc = or $ maybe [] (fmap g) $+ ignoredAccountsOnAdd user+ where g ign = R.match (rRegex ign) acc++data Regex = Regex+ {rShow :: T.Text+ , rRegex :: R.Regex+ }++instance FromJSON Regex where+ parseJSON (String v) = Regex v <$> R.makeRegexM v+ parseJSON invalid = A.typeMismatch "regex string" invalid++instance Show Regex where+ show = T.unpack . rShow++data AccountId = AccountId { aBank :: T.Text+ , aAccount :: T.Text }+ deriving (Generic, Eq, Ord, Hashable, Show)++type AccountMap = HM.HashMap AccountId AccountName++instance (Hashable a, Eq a) => Default (HM.HashMap a b) where+ def = mempty++instance FromJSON BankAccounts where+ parseJSON (Object v) = BankAccounts . HM.fromList . concat+ <$> traverse parseAccountMap (HM.toList v)+ parseJSON invalid = A.typeMismatch "BankAccounts" invalid++parseAccountMap :: FromJSON b => (T.Text, Value) -> Parser [(AccountId, b)]+parseAccountMap (bank, (Object m)) = traverse f $ HM.toList m+ where f (acc,v) = (,) (AccountId bank acc) <$> parseJSON v+parseAccountMap (_, invalid) = A.typeMismatch "parseAccountMap" invalid++-- * AQBanking++data AQBankingConf = AQBankingConf+ { connections :: [AQConnection]+ , configDir :: FilePath+ , aqBankingExecutable :: Maybe FilePath+ , aqhbciToolExecutable :: Maybe FilePath+ }+ deriving ( DERIVING )++data AQConnection = AQConnection+ { aqUser :: String+ , aqBlz :: String+ , aqUrl :: String+ , aqHbciv :: HBCIv+ , aqName :: String+ , aqType :: AQType+ }+ deriving ( Generic, Show)++instance FromJSON AQConnection where+ parseJSON = A.genericParseJSON $ stripPrefixOptions 2++instance ToJSON AQConnection where+ toEncoding = A.genericToEncoding $ stripPrefixOptions 2++-- -- | workaround yaml problem, where 46549 does not parse as a string.+-- newtype String2 = String2 String+-- deriving ( Generic, Show)++-- instance FromJSON String2 where+-- parseJSON (String v) = String2 v+-- parseJSON (Number v) = String2 v++-- | other modes have to be setup manually. Refer to the AQBanking+-- manual. Use the '-C' to point to the configured 'configDir'.+data AQType = PinTan+ | Other+ deriving ( Generic, Show, FromJSON, ToJSON, Eq )++data HBCIv = HBCI201+ | HBCI210+ | HBCI220+ | HBCI300+ deriving ( Generic, Show, FromJSON, ToJSON )++toArg HBCI201 = "201"+toArg HBCI210 = "210"+toArg HBCI220 = "220"+toArg HBCI300 = "300"++-- readAQ+-- :: (MonadError Msg m, MonadReader (Options User config env) m) =>+-- (AQBankingConf -> m b) -> m b+-- readAQ f = do++-- * Actions+++type PaypalUsername = T.Text++data Action = Add { aPartners :: [Username] }+ | Match+ | Import { iVersion :: Maybe Version+ , iPath :: FilePath+ , iAction :: ImportAction }+ | Update { aqVersion :: Maybe Version+ , aqMatch :: Bool+ -- ^ run match after import+ , aqRequest :: Bool+ -- ^ request new transactions+ }+ | Commit { cArgs :: [String] }+ | ListBalances+ | Setup+ | Ledger { lArgs :: [String] }+ | HLedger { hlArgs :: [String] }+ | AQBanking { aqArgs :: [String] }++ deriving (Show, Generic, NFData)+++data ImportAction = Paypal PaypalUsername+ | AQBankingImport+ | ComdirectVisa { comdirectVisaBlz :: T.Text }+ deriving (Show, Generic, NFData)+++-- * Misc+++type Comment = T.Text
+ src/Buchhaltung/Uniques.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+module Buchhaltung.Uniques+where++import Buchhaltung.Common+import Control.Arrow hiding (loop)+import Control.Monad.RWS.Strict+import Control.Monad.Trans.Cont+import Data.Function+import Data.List+import qualified Data.ListLike as L+import qualified Data.ListLike.String as L+import qualified Data.Map as M+import Data.Ord+import qualified Data.Text as T+import qualified Data.Text.IO as T+import qualified Data.Text.Lazy as TL+import Data.Time.Calendar+import Formatting as F+import qualified Formatting.ShortFormatters as F+import Hledger.Data+import System.IO+import Text.EditDistance+import qualified Text.PrettyPrint.Boxes as P+import Text.Printf++-- | The monad stack+type M r m = ContT r (RWST () () (M.Map Key Entry) m)++-- | the key that is used to compare transactions. The Int is a+-- counter, to ensure there are no actual duplicates in the+-- map.+--+-- Instead duplicates are found by extraction of a key range using+-- 'M.split'. See 'findDuplicates'.+type Key = ([(CommoditySymbol,Quantity)], AccountName, Day, Int)++addNew :: (MonadIO m, MonadReader (Options user Config env) m)+ => [FilledEntry]+ -- ^ new candidates including entries already existing in+ -- journal possible duplicates+ -> Journal+ -> m [Entry]+addNew newTxs journal = do+ tag <- askTag+ let g i tx = (key tx i+ , ImportedEntry tx () $ wSource <$> extractSource tag tx)+ fmap (M.elems . fst)+ <$> execRWST (evalContT $ callCC $ \exit -> zipWithM_+ (loop exit $ length newTxs) [1..] newTxs)+ () $ M.fromList+ $ zipWith g [1..] (jtxns journal)+++key :: Transaction -> Int -> Key+key tx i = (compAmount $ pamount p, paccount p, tdate tx, i)+ where compAmount (Mixed am) = sort+ $ fmap (\x -> (acommodity x, aquantity x)) am+ p = head $ tpostings tx++-- | loop through all existing possible duplicates of a new+-- transaction+loop :: (MonadIO m, MonadReader (Options user Config env) m)+ => (() -> M r m ())+ -> Int -> Int -> FilledEntry -> M r m ()+loop exit totalTx iTx new = do+ new' <- gets $ \old -> (key (ieT new) $ M.size old + 1, new)+ dups <- findDuplicates new'+ let msg = format ("Transaction: "%F.d%" of "%F.d%" new\n") iTx totalTx+ checkOrAsk exit new' msg+ $ sortBy (flip $ comparing snd)+ $ (id &&& g) <$> dups+ where g (_, y) = negate . on+ (restrictedDamerauLevenshteinDistance defaultEditCosts)+ (TL.unpack . json) (ieSource new)+ <$> (eitherToMaybe $ ieSource y)++eitherToMaybe :: Either b a -> Maybe a+eitherToMaybe = either (const Nothing) Just++findDuplicates :: Monad m => (Key, FilledEntry) -> M r m [(Key,Entry)]+findDuplicates ((ams,acc,day,ix), _) = lift $ gets $ \old ->+ let later = snd $ M.split (ams,acc,day,0) old in+ M.toList $ fst $ M.split (ams,acc,addDays 1 day,ix) later++-- | check single new entry against a list of conflict+-- candidates, and insert new entry (if list is empty), or keep old+-- entry (if identical to new one), or ask weither to modify old entry+-- or insert new entry.+checkOrAsk :: (MonadIO m, MonadReader (Options user Config env) m)+ => (() -> M r m ())+ -> (Key, FilledEntry)+ -> TL.Text -- ^ message+ -> [((Key,Entry), Maybe Int)] -> M r m ()+checkOrAsk _ new _ [] = do+ modify $ uncurry M.insert $ second fromFilled new+ liftIO $ T.putStrLn "\nSaved new transaction.\n"+checkOrAsk exit new msg (( (oldKey,oldEntry), cost):remaining) = do+ if cost == Just 0 then return () -- do nothing, i.e. use old unchanged+ else if False && cost > Just ( - 98)+ && on (==) (tdate.ieT) oldEntry (fromFilled $ snd new) then do+ -- liftIO $ do print (fst new) >> print (oldKey)+ -- print (tdate.ieT.snd $ new) >> print (tdate.ieT $ oldEntry)+ -- print (ieSource.snd $ new) >> print (ieSource $ oldEntry)+ overwriteOldSource+ else do+ let question = (answer =<<) . liftIO $ do+ L.putStr $ L.unlines+ [ prettyPrint cost (snd new) oldEntry msg $ length remaining+ , "Yes, they are duplicates. Update the source [y]"+ , "No, " <> (if null remaining then "Save as new transaction"+ else "Show next duplicate") <> " [n]"+ , "Skip this new transaction [q]"+ , "Skip this and all remaining transactions [Q]"+ , "Your answer:" ]+ hSetBuffering stdin NoBuffering+ getChar <* putStrLn ""+ answer 'y' = overwriteOldSource+ answer 'n' = checkOrAsk exit new msg remaining+ answer 'q' = return ()+ answer 'Q' = exit ()+ answer _ = question+ question+ where+ overwriteOldSource = lift $ do+ tag <- lift $ askTag+ modify $ M.adjust (applyChanges tag new oldKey) oldKey+ liftIO $ T.putStrLn "\nUpdated duplicate's source.\n"++prettyPrint :: Maybe Int -> FilledEntry -> Entry -> TL.Text -- ^ Message+ -> Int -- ^ Remaining+ -> T.Text+prettyPrint cost new old msg remain =+ let union2 = f . second unzip . unzip+ . M.toList . union+ union old = M.mergeWithKey g+ (fmap $ flip (,) "<empty>") (fmap $ (,) "<empty>")+ old $ sourceToMap $ ieSource new+ g _ x y | x == y = Just $ (x, "")+ | True = Just $ (x, y)+ f (k,(old,new)) = T.pack $ P.render+ $ table [20, 25, 25] header [k, old, new]+ header = ["Field", "Old", "New"]+ oldSource = ieSource old+ showError (Left x) = [""+ ,"Error retrieving old transaction's source:"+ , T.pack x]+ showError (Right _) = []+ def _ Nothing = "n.a."+ def f (Just x) = f x+ in+ L.unlines $+ [ union2 . either (const mempty) sourceToMap $ oldSource ]+ ++ [ sformat+ ("changes: "%F.s%"/"%F.s%"\n"%F.t%"Remaining existing duplicates: "%F.d)+ (def (show . negate) cost)+ (def (show . TL.length . json) $ eitherToMaybe $ ieSource old)+ msg+ remain+ ]+ ++ showError oldSource+++applyChanges :: ImportTag -> (Key, FilledEntry)+ -> Key -> Entry -> Entry+applyChanges tag ((ams2,acc2,day2,_),newEntry)+ (ams1, acc1, _, _) oldEntry =+ if (ams2,acc2) /= (ams1,acc1) then+ error $ unlines ["Change not supported: "+ , show newEntry+ , show oldEntry]+ else oldEntry{ieT= (injectSource tag (ieSource newEntry)+ $ ieT oldEntry){tdate = day2}}
+ src/Buchhaltung/Utils.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+module Buchhaltung.Utils where++import Control.Arrow+import qualified Control.Exception.Lifted as E+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Control+import qualified Data.ListLike as L+import Data.Monoid+import Data.String+import System.Directory+import System.IO+import qualified System.IO.Temp as T+import System.Process+ +-- | apply a funtion to the ith element of a list+modifyNth :: (a -> a) -> Int -> [a] -> [a]+modifyNth f n = zipWith z [0..]+ where z i | i == n = f+ | otherwise = id++fshow :: (Show a, IsString b) => a -> b+fshow = fromString . show++intercalateL+ :: (L.ListLike a item, L.ListLike b a) =>+ a -> b -> a+intercalateL x = L.concat . L.intersperse x+++map2 :: Arrow a => a b' c' -> a (b', b') (c', c')+map2 = join (***)++-- withTempFileM :: (MonadIO m, MonadBaseControl IO m)+-- => FilePath -> IOMode -> (Handle -> m r) -> m r+-- withTempFileM name mode = E.bracket (liftIO $ openFile name mode)+-- (liftIO . hClose)++withFileM :: (MonadIO m, MonadBaseControl IO m)+ => FilePath -> IOMode -> (Handle -> m r) -> m r+withFileM name mode = E.bracket (liftIO $ openFile name mode)+ (liftIO . hClose)+++#if ! MIN_VERSION_base(4,9,0)+instance Monoid a => Monoid (IO a) where+ mempty = pure mempty+ mappend = liftM2 mappend+#endif++ +doesPathExist :: FilePath -> IO Bool+doesPathExist = fmap getAny . (a . doesFileExist <> a . doesDirectoryExist)+ where a = fmap Any +++-- * Ported from 'System.IO.Temp' to work with 'MonadBaseControl'+ +withSystemTempFile template action = liftIO getTemporaryDirectory >>= \tmpDir -> withTempFile tmpDir template action+ +withSystemTempDirectory template action = liftIO getTemporaryDirectory >>= \tmpDir -> withTempDirectory tmpDir template action++withTempDirectory targetDir template =+ E.bracket+ (liftIO (T.createTempDirectory targetDir template))+ (liftIO . ignoringIOErrors . removeDirectoryRecursive)++ +withTempFile tmpDir template action =+ E.bracket+ (liftIO (openTempFile tmpDir template))+ (\(name, handle) -> liftIO (hClose handle >> ignoringIOErrors (removeFile name)))+ (uncurry action)+++ignoringIOErrors :: MonadBaseControl IO m => m () -> m ()+ignoringIOErrors ioe = ioe `E.catch` (\e -> const (return ()) (e :: IOError))++mconcat' :: Monoid t => [t] -> t+mconcat' [] = mempty+mconcat' x = foldr1 mappend x+++(<&>) :: Functor f => (a -> b) -> f a -> f b+(<&>) = (<$>)++infixr 0 <&>++readProcess' :: FilePath -> [String] -> IO String+readProcess' x y = readProcess x y ""
+ src/Buchhaltung/ZipEdit2.hs view
@@ -0,0 +1,429 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-----------------------------------------------------------------------------+-- |+-- Module : System.Console.ZipEdit+-- Copyright : (c) 2008 Brent Yorgey+-- License : BSD-style (see LICENSE)+--+-- Maintainer : <byorgey@gmail.com>+-- Stability : unstable+-- Portability : unportable+--+-- A library for creating simple interactive list editors, using a+-- zipper to allow the user to navigate forward and back within the+-- list and edit the list elements.+-----------------------------------------------------------------------------+++module Buchhaltung.ZipEdit2+ (+ -- * Example usage+ -- $sample++ -- * Interface++ Action(..)+ , stdActions+ , (??)+ , EditorConf(..)+ , edit++ , LCont(..)+ , editWCont+ , Zipper(..)+ , integrate+ , differentiate+ , fwd, back+ , LState(..) + ) where++import Buchhaltung.Zipper+import Control.Arrow+import Control.Monad.RWS.Strict+import qualified Data.List.NonEmpty as E+import qualified Data.Text as T+import qualified Data.Text.IO as T+import System.Directory (removeFile)+import System.IO+import System.Process++{- $sample++Here is a simple example of using the ZipEdit library:++> module Main where+>+> import System.Console.ZipEdit+>+> myEd = EC { display = const ""+> , ecPrompt = \n -> maybe "" show n ++ "? "+> , actions = [ ('+', Modify (+1) ?? "Increment the current number.")+> , ('i', InsFwd "Value to insert: " read ?? "Insert a number.")+> ]+> ++ stdActions+> }+>+> main = do+> mxs <- edit myEd [1..10]+> case mxs of+> Nothing -> putStrLn "Canceled."+> Just xs -> putStrLn ("Final edited version: " ++ show xs)++A session with this program might look something like this:++> $ test+>+> 1? k+>+> 1? j+>+> 2? j+>+> 3? ++>+> 4? ++>+> 5? j+>+> 4? i+> Value to insert: 98+>+> 98? d+> Final edited version: [1,2,5,4,98,5,6,7,8,9,10]++For more sophisticated examples, see @planethaskell.hs@ and @gmane.hs@ in+<http://code.haskell.org/~byorgey/code/hwn/utils>.++-}++-- | A continuation which can compute more of the list, along with+-- (maybe) another continuation.+data LCont a = LC (IO ([a], Maybe (LCont a)))++-- | The state of the editor consists of a current context, as well as+-- an optional continuation which can compute more list elements.+data LState a b = LS { ctx :: Zipper a+ , cont :: Maybe (LCont a)+ , userSt :: b+ }++-- | Perform a ModifyAllM action by running the given IO action and+-- | using it to replace all elements.+doModifyAllM :: Monad m => (Zipper e -> m (Zipper e)) -> Editor e u m ()+doModifyAllM m = do+ s <- get+ lift (m $ ctx s) >>= modifyCtx . const+ +-- | Perform a ModifyAllM action by running the given IO action and+-- | using it to replace all elements.+doModifyStateM :: Monad m => (LState e u -> m (LState e u)) -> Editor e u m ()+doModifyStateM m = do+ get >>= (lift . m) >>= put+ ++-- | Actions that can be taken by an editor in response to+-- user input.+data Action m a u = Comp (Action m a u) (Action m a u) | + Fwd -- ^ move forward one item.+ | Back -- ^ move back one item.+ | Delete -- ^ delete the current item.+ | Modify (a -> a) -- ^ modify the current item by applying+ -- the given function.+ | ModifyState (LState a u -> LState a u)+ -- ^ modify complete state+ | ModifyStateM (LState a u -> m (LState a u))+ -- ^ modify complete state with IO.+ | ModifyAllM (Zipper a -> m (Zipper a))+ -- ^ modify everything with IO.+ | ModifyAll (Zipper a -> Zipper a)+ -- ^ modify everything.+ | ModifyM (a -> m a)+ -- ^ modify the current item by+ -- applying the given function,+ -- which gives its result in the+ -- IO monad.+ | ModifyFwd ([a] -> [a])+ -- ^ modify items following+ -- the current item by applying+ -- the given function.+ | ModifyBack ([a] -> [a])+ -- ^ modify items before the+ -- current item by applying the+ -- given function.+ | ModifyWInp String (String -> a -> a)+ -- ^ Using the given string as a+ -- prompt, obtain a line of user+ -- input, and apply the given+ -- function to the user input to+ -- obtain a function for+ -- modifying the current item.+ | ModifyWEditor (a -> String) (String -> a -> a)+ -- ^ Run the first function on the+ -- current item to produce a+ -- string, and open an editor+ -- (using the $EDITOR+ -- environment variable) on that+ -- string. After the user is+ -- done editing, pass the+ -- resulting string to the+ -- second function to obtain a+ -- function for modifying the+ -- current element.+ | InsFwd String (String -> a)+ -- ^ Using the given string as a+ -- prompt, obtain a line of user+ -- input, and apply the given+ -- function to the user input to+ -- obtain a new item, which+ -- should be inserted forward of+ -- the current item. The+ -- inserted item becomes the new+ -- current item.+ | InsBack String (String -> a)+ -- ^ Similar to InsFwd, except+ -- that the new item is inserted+ -- before the old current item.+ | Output (a -> String)+ -- ^ output a string which is a+ -- function of the current item.+ | Cancel -- ^ cancel the editing session.+ | Done (LState a u -> m (Maybe (LState a u)))+ -- ^ complete the editing+ -- session, but if te function evaluates+ -- to "Just" and the suer+ -- answers y. In this case+ -- return the functions result.+ | Seq [Action m a u] -- ^ perform a sequence of actions.+ | Help String (Action m a u)+ -- ^ an action annotated with a+ -- help string.++instance Monoid (Action m a u) where+ mappend = Comp+ mempty = Seq []+ +-- | Annotate a command with a help string.+(??) :: Action m a u -> String -> Action m a u+(??) = flip Help++-- | Some standard actions which can be used in constructing editor+-- configurations. The actions are: j - Fwd, k - Back, x -+-- Delete, q - Cancel, d - Done.+stdActions :: Monad m => [(Char, Action m a u)]+stdActions = [ ('j', Fwd ?? "Move forward one item.")+ , ('k', Back ?? "Move backward one item.")+ , ('x', Delete ?? "Delete the current item.")+ , ('q', Cancel ?? "Cancel the current editing session.")+ , ('d', Done (return . Just) ?? "Complete the current editing session.")+ ]++-- | A configuration record determining the behavior of the editor.+data EditorConf m a u = EC { display :: LState a u -> m T.Text+ -- ^ How to display info about the current state.+ , ecPrompt :: Zipper a -> String+ -- ^ How to display info about the all elements.+ , actions :: [(Char, Action m a u)]+ -- ^ A list specifying the actions to take+ -- in response to user inputs.+ , getchar :: Maybe (IO Char)+ -- ^ optional different getChar implementation+ }++-- | Editor monad: a reader monad with the editor configuration, plus+-- | a state monad for storing the context, plus IO for interacting+-- | with the user.+newtype Editor e userState m a = E (RWST+ (EditorConf m e userState) ()+ (LState e userState) m a)+ deriving (Functor, Monad, Applicative+ , MonadWriter ()+ , MonadState (LState e userState)+ , MonadReader (EditorConf m e userState)+ , MonadRWS (EditorConf m e userState) () (LState e userState)+ , MonadIO)++instance MonadTrans (Editor e userState) where+ lift = E . lift++-- | Convenient shorthand for liftIO.+io :: MonadIO m => IO a -> m a+io = liftIO++-- | Run an action in the Editor monad, given an editor configuration,+-- | a starting list, and an optional continuation.+runEditor :: MonadIO m => Editor e u m a -> EditorConf m e u -> E.NonEmpty e ->+ Maybe (LCont e) -> u -> (Zipper e -> Zipper e) -> m a+runEditor (E e) ec l c userState mod = do+ io $ do hSetBuffering stdin NoBuffering+ hSetBuffering stdout NoBuffering+ fst <$> evalRWST e ec (LS (mod $ differentiate l) c userState)++-- | Lift a pure function on a context into a state modification+-- | action in the Editor monad.+modifyCtx :: Monad m => (Zipper e -> Zipper e) -> Editor e u m () -- +modifyCtx f = do+ LS a b u <- get+ put (LS (f a) b u)++-- | Run the given editor on the given list, returning @Nothing@ if+-- the user canceled the editing process, or @Just l@ if the editing+-- process completed successfully, where @l@ is the final state of+-- the list being edited.+edit :: MonadIO m => EditorConf m a u -- ^ editor configuration+ -> u -- ^ initial userState+ -> E.NonEmpty a -- ^ the list to edit+ -> (Zipper a -> Zipper a) -- ^ startupModifier+ -> m (Maybe (u,[a]))+edit ec u l mod = runEditor process ec l Nothing u mod++-- | Like 'edit', but with an additional parameter for a continuation+-- | which can be run to compute additional list elements and+-- | (optionally) another continuation.+editWCont :: MonadIO m => EditorConf m a u+ -> E.NonEmpty a -- ^ the list to edit+ -> u -- ^ initial userState+ -> IO ([a], Maybe (LCont a))+ -> (Zipper a -> Zipper a) -- ^ startupModifier+ -> m (Maybe (u,[a]))+editWCont ec l u c mod = runEditor process ec l (Just (LC c)) u mod++-- | The main Editor action implementing a zipedit-created interface.+process :: MonadIO m => Editor a u m (Maybe (u,[a]))+process = do+ s <- get+ e <- ask+ let cur = ctx s+ display' <- lift $ display e s+ ch <- io $ do putStr "\n"+ T.putStr display' + putStr (ecPrompt e cur)+ maybe getChar id $ getchar e+ io $ putStr "\n"++ -- res: Nothing = cancel, Just True = continue, Just False = done+ res <- if ch == '?'+ then showHelp (actions e) >> continue+ else case lookup ch (actions e) of+ Nothing -> return (Just True)+ Just act -> doAction act+ case res of+ Nothing -> return Nothing+ Just True -> process+ Just False -> Just . (userSt &&& (integrate . ctx)) <$> get++-- | Display any help annotations provided by the user.+showHelp :: MonadIO m => [(Char, Action m a u)] -> Editor a u m ()+showHelp cs = io $ mapM_ (putStrLn . showCmdHelp) (helpCmd:cs)+ where helpCmd = ('?', Fwd ?? "Show this help.")+ showCmdHelp (c, Help s _) = c : (" - " ++ s)+ showCmdHelp (c, _) = c : " -"++-- | Perform an action, returning an indication of the status: Nothing+-- | indicates cancellation of the editing process; Just True+-- | indicates that processing should continue; Just False indicates+-- | that processing is complete.+doAction :: MonadIO m => Action m a u -> Editor a u m (Maybe Bool)+doAction Fwd = doFwd >> continue+doAction Back = modifyCtx back >> continue+doAction Delete = modifyCtx delete >> continue+doAction (Modify f) = modifyCtx (modifyPresent f) >> continue+doAction (ModifyM m) = doModifyM m >> continue+doAction (ModifyFwd f) = modifyCtx (modifyFwd f) >> continue+doAction (ModifyAll f) = modifyCtx f >> continue+doAction (ModifyAllM f) = doModifyAllM f >> continue+doAction (ModifyState f) = modify f >> continue+doAction (ModifyStateM f) = doModifyStateM f >> continue+doAction (ModifyBack f) = modifyCtx (modifyBack f) >> continue+doAction (ModifyWInp p f) = doModifyPrompt p f >> continue+doAction (ModifyWEditor f g) = doModifyWithEditor f g >> continue+doAction (InsFwd p f) = doInsPrompt p f >>= modifyCtx . insfwd >> continue+doAction (InsBack p f) = doInsPrompt p f >>= modifyCtx . insback >> continue+doAction (Output f) = doOutput f >> continue+doAction Cancel = doCancel+doAction (Comp a b) = doAction a >> doAction b+doAction (Done f) = doQuit f+doAction (Seq as) = fmap (fmap and . sequence) $ mapM doAction as+doAction (Help _ a) = doAction a++continue :: Monad m => Editor a u m (Maybe Bool)+continue = return $ Just True+++doQuit :: MonadIO m+ => (LState a u -> m (Maybe (LState a u)))+ -> Editor a u m (Maybe Bool)+doQuit f = do s <-get+ (lift $ f s) >>= maybe (return (Just True)) ((>> quit) . put)+ where quit = io $ yesNo "Save? [y/N] "+ (Just False) -- quit with result+ (Just True) -- continue editing++-- | Prompt the user to confirm a cancel.+doCancel :: MonadIO m => Editor a u m (Maybe Bool)+doCancel = io $ + yesNo "Discard all edits, are you SURE? [y/N] "+ Nothing -- quit with nothing+ (Just True) -- continue editing++-- Ask yesNo question+yesNo :: String -- ^ question+ -> a -> a -> IO a+yesNo q a b = do putStr q+ x <- getChar+ return $ if x `elem` ("yY"::String) then a else b++-- | Move the focus one element forward, unless we are at the end of+-- | the list. If we are at the end of a list and there is a+-- | continuation, run it and append the generated elements, moving to+-- | the first of the new elements; otherwise do nothing.+doFwd :: MonadIO m => Editor e u m ()+doFwd = do+ LS{ctx=z,cont=s} <- get+ case (future z, s) of+ ([], Just (LC c)) -> do (newElts, cont') <- io c+ modifyCtx (fwd . modifyFwd (++newElts))+ (LS l _ u) <- get+ put (LS l cont' u)+ ([], Nothing) -> return ()+ _ -> modifyCtx fwd++-- | Perform a ModifyM action by running the given IO action and+-- | using it to replace the currently focused element.+doModifyM :: Monad m => (e -> m e) -> Editor e u m ()+doModifyM m = do+ pr <- gets $ present . ctx + lift (m pr) >>= modifyCtx . modifyPresent . const++-- | Perform a ModifyWInp action by prompting the user and using their+-- | input to modify the currently focused element.+doModifyPrompt :: MonadIO m => String -> (String -> e -> e) -> Editor e u m ()+doModifyPrompt p f = do+ io $ putStr p+ inp <- io getLine+ modifyCtx (modifyPresent $ f inp)++doModifyWithEditor :: MonadIO m =>+ (e -> String) -> (String -> e -> e) -> Editor e u m ()+doModifyWithEditor toStr fromStr = do+ pr <- gets $ present . ctx + editTmpFile pr >>= modifyCtx . modifyPresent . fromStr+ where editTmpFile z = io $ do+ (tmp,h) <- openTempFile "/tmp" "zipedit.txt"+ hPutStr h $ toStr z+ hClose h+ _ <- system $ "$EDITOR " ++ tmp+ txt <- readFile tmp+ removeFile tmp+ return txt++-- | Prompt the user, convert their input to an element, and return+-- | the element.+doInsPrompt :: MonadIO m => String -> (String -> e) -> Editor e u m e+doInsPrompt p f = do+ io $ putStr p+ f `fmap` io getLine++-- | Output a function of the currently focused element.+doOutput :: MonadIO m => (e -> String) -> Editor e u m ()+doOutput f = do+ io . putStr . f =<< gets (present . ctx)
+ src/Buchhaltung/Zipper.hs view
@@ -0,0 +1,74 @@+{-# OPTIONS_HADDOCK ignore-exports #-}+module Buchhaltung.Zipper+ (module Buchhaltung.Zipper+ , E.NonEmpty(..)+ , E.nonEmpty+ ) where++import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as E+import Data.Monoid++-- | Nonemtpy zipper+data Zipper a = LZ { past :: E.NonEmpty a+ , future :: [a]+ }++present :: Zipper a -> a+present = E.head . past++instance Functor Zipper where+ fmap f (LZ ps fs) = LZ (E.map f ps) (map f fs)++-- | Re-constitute a list from a zipper context.+integrate' :: Zipper a -> E.NonEmpty a+integrate' (LZ p f) = E.fromList $ reverse (E.toList p) <> f++integrate :: Zipper a -> [a]+integrate = E.toList . integrate'++-- | Turn a list into a context with the focus on the first element.+differentiate :: E.NonEmpty a -> Zipper a+differentiate (x :| xs) = LZ (pure x) xs++-- | Move the focus to the previous element. Do nothing if the focus+-- | is already on the first element.+back :: Zipper a -> Zipper a+back z@(LZ (_ :| []) _) = z+back (LZ (pr :| (np:ps)) fs) = LZ (np :| ps) (pr:fs)++-- | Move the focus to the next element. Do nothing if the focus is+-- | already on the last element.+fwd :: Zipper a -> Zipper a+fwd z@(LZ _ []) = z+fwd (LZ ps (f:fs)) = LZ (f E.<| ps) fs++-- | Apply the given function to the currently focused element to+-- | produce a new currently focused element.+modifyPresent :: (a -> a) -> Zipper a -> Zipper a+modifyPresent f z@LZ{past=(present :| past)} = z { past = (f present :| past) }++-- | Apply the given function to all elements preceding the focus.+modifyBack :: ([a] -> [a]) -> Zipper a -> Zipper a+modifyBack f z@LZ{ past=(pr :| ps) } = z { past = (pr :| f ps) }++-- | Apply the given function to all elements after the focus.+modifyFwd :: ([a] -> [a]) -> Zipper a -> Zipper a+modifyFwd f z = z { future = f (future z) }++-- | Delete the currently focused element. If there are no future+-- elements move the focus to the next last element.+delete :: Zipper a -> Zipper a+delete (LZ (_ :| []) [] ) = error "empty zipper not allowed"+delete (LZ (_ :| (np:past)) [] ) = LZ (np :| past) []+delete (LZ (_ :| past) (np:f) ) = LZ (np :| past) f++-- | Insert a new element just before the current focus, then move the+-- | focus to the newly inserted element.+insback :: a -> Zipper a -> Zipper a+insback x (LZ (pr :| ps) fs) = LZ (x :| ps) (pr:fs)++-- | Insert a new element just after the current focus, then move the+-- | focus to the newly inserted element.+insfwd :: a -> Zipper a -> Zipper a+insfwd x (LZ ps fs) = LZ (x E.<| ps) fs
+ src/main.hs view
@@ -0,0 +1,4 @@+import Buchhaltung.Commandline++main :: IO ()+main = runMain
+ stack.yaml view
@@ -0,0 +1,11 @@+flags: {}+packages:+- '.'+- location:+ git: https://github.com/simonmichael/hledger.git+ commit: 282e85c6028227938457fb3b94eb333c4ba4ae65+ subdirs:+ - hledger-lib+ extra-dep: true++resolver: nightly-2016-12-17