diff options
| author | Rutger Broekhoff | 2025-11-27 23:35:08 +0100 |
|---|---|---|
| committer | Rutger Broekhoff | 2025-11-27 23:35:08 +0100 |
| commit | 46169ec3eb38e177cafd7faf6338d36c6a9e3971 (patch) | |
| tree | ff4147b884c2f5533d5a7bae3f1211af43dc14a4 /lib | |
| parent | 80e1f41596ca9955b432addbf01b913d864aa7c0 (diff) | |
| download | rdcapsis-ocaml.tar.gz rdcapsis-ocaml.zip | |
Whatever all of this isocaml
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/convert.ml | 90 | ||||
| -rw-r--r-- | lib/dune | 9 | ||||
| -rw-r--r-- | lib/iban.ml | 11 | ||||
| -rw-r--r-- | lib/iban.mli | 2 | ||||
| -rw-r--r-- | lib/ingcsv.ml | 5 | ||||
| -rw-r--r-- | lib/ledger.ml | 192 | ||||
| -rw-r--r-- | lib/ledger.mli | 133 | ||||
| -rw-r--r-- | lib/preledger.ml | 217 |
8 files changed, 538 insertions, 121 deletions
diff --git a/lib/convert.ml b/lib/convert.ml index 5afc95e..5411fcc 100644 --- a/lib/convert.ml +++ b/lib/convert.ml | |||
| @@ -12,6 +12,18 @@ type convert_err = Nonpositive_amount | Other of Tx.error | |||
| 12 | let cents n = Amount (Money.of_z n) | 12 | let cents n = Amount (Money.of_z n) |
| 13 | 13 | ||
| 14 | let tx_from_current_acc euc_id (Ingcsv.Tx (base, spec)) = | 14 | let tx_from_current_acc euc_id (Ingcsv.Tx (base, spec)) = |
| 15 | let make_tx_entries ~on_checking = | ||
| 16 | Account_id_map.of_alist_exn | ||
| 17 | [ | ||
| 18 | ( virt_checking_acc, | ||
| 19 | ( on_checking, | ||
| 20 | cents base.amount, | ||
| 21 | Some (Money.of_z base.resulting_balance) ) ); | ||
| 22 | ( virt_counterparty, | ||
| 23 | (Debit_credit.opposite on_checking, cents base.amount, None) ); | ||
| 24 | ] | ||
| 25 | and base_labels = Labels.singleton (Iban_label Account_tag) base.account in | ||
| 26 | |||
| 15 | if Z.(lt base.amount ~$0) then Error Nonpositive_amount | 27 | if Z.(lt base.amount ~$0) then Error Nonpositive_amount |
| 16 | else | 28 | else |
| 17 | Result.map_error ~f:(fun e -> Other e) | 29 | Result.map_error ~f:(fun e -> Other e) |
| @@ -19,14 +31,10 @@ let tx_from_current_acc euc_id (Ingcsv.Tx (base, spec)) = | |||
| 19 | match spec with | 31 | match spec with |
| 20 | | Payment_terminal_payment details -> | 32 | | Payment_terminal_payment details -> |
| 21 | Tx.make ~cleared:(Some base.date) ~commodity_id:euc_id | 33 | Tx.make ~cleared:(Some base.date) ~commodity_id:euc_id |
| 22 | ~credit: | 34 | ~entries:(make_tx_entries ~on_checking:Debit_credit.Credit) |
| 23 | (Account_id_map.singleton virt_checking_acc @@ cents base.amount) | ||
| 24 | ~debit: | ||
| 25 | (Account_id_map.singleton virt_counterparty @@ cents base.amount) | ||
| 26 | ~labels: | 35 | ~labels: |
| 27 | Labels.( | 36 | Labels.( |
| 28 | empty | 37 | base_labels |
| 29 | |> add (Iban_label Account_tag) base.account | ||
| 30 | |> add (String_label Counterparty_name_tag) | 38 | |> add (String_label Counterparty_name_tag) |
| 31 | details.counterparty_name | 39 | details.counterparty_name |
| 32 | |> add (String_label Card_seq_no_tag) details.card_sequence_no | 40 | |> add (String_label Card_seq_no_tag) details.card_sequence_no |
| @@ -38,14 +46,10 @@ let tx_from_current_acc euc_id (Ingcsv.Tx (base, spec)) = | |||
| 38 | else Fn.id) | 46 | else Fn.id) |
| 39 | | Payment_terminal_cashback details -> | 47 | | Payment_terminal_cashback details -> |
| 40 | Tx.make ~cleared:(Some base.date) ~commodity_id:euc_id | 48 | Tx.make ~cleared:(Some base.date) ~commodity_id:euc_id |
| 41 | ~debit: | 49 | ~entries:(make_tx_entries ~on_checking:Debit_credit.Debit) |
| 42 | (Account_id_map.singleton virt_checking_acc @@ cents base.amount) | ||
| 43 | ~credit: | ||
| 44 | (Account_id_map.singleton virt_counterparty @@ cents base.amount) | ||
| 45 | ~labels: | 50 | ~labels: |
| 46 | Labels.( | 51 | Labels.( |
| 47 | empty | 52 | base_labels |
| 48 | |> add (Iban_label Account_tag) base.account | ||
| 49 | |> add (String_label Counterparty_name_tag) | 53 | |> add (String_label Counterparty_name_tag) |
| 50 | details.counterparty_name | 54 | details.counterparty_name |
| 51 | |> add (String_label Card_seq_no_tag) details.card_sequence_no | 55 | |> add (String_label Card_seq_no_tag) details.card_sequence_no |
| @@ -54,14 +58,10 @@ let tx_from_current_acc euc_id (Ingcsv.Tx (base, spec)) = | |||
| 54 | |> add Timestamp_label details.timestamp) | 58 | |> add Timestamp_label details.timestamp) |
| 55 | | Online_banking_credit details -> | 59 | | Online_banking_credit details -> |
| 56 | Tx.make ~cleared:(Some base.date) ~commodity_id:euc_id | 60 | Tx.make ~cleared:(Some base.date) ~commodity_id:euc_id |
| 57 | ~debit: | 61 | ~entries:(make_tx_entries ~on_checking:Debit_credit.Debit) |
| 58 | (Account_id_map.singleton virt_checking_acc @@ cents base.amount) | ||
| 59 | ~credit: | ||
| 60 | (Account_id_map.singleton virt_counterparty @@ cents base.amount) | ||
| 61 | ~labels: | 62 | ~labels: |
| 62 | Labels.( | 63 | Labels.( |
| 63 | empty | 64 | base_labels |
| 64 | |> add (Iban_label Account_tag) base.account | ||
| 65 | |> add (String_label Counterparty_name_tag) | 65 | |> add (String_label Counterparty_name_tag) |
| 66 | details.counterparty_name | 66 | details.counterparty_name |
| 67 | |> add (Iban_label Counterparty_iban_tag) | 67 | |> add (Iban_label Counterparty_iban_tag) |
| @@ -70,14 +70,10 @@ let tx_from_current_acc euc_id (Ingcsv.Tx (base, spec)) = | |||
| 70 | |> add Timestamp_label details.timestamp) | 70 | |> add Timestamp_label details.timestamp) |
| 71 | | Online_banking_debit details -> | 71 | | Online_banking_debit details -> |
| 72 | Tx.make ~cleared:(Some base.date) ~commodity_id:euc_id | 72 | Tx.make ~cleared:(Some base.date) ~commodity_id:euc_id |
| 73 | ~debit: | 73 | ~entries:(make_tx_entries ~on_checking:Debit_credit.Credit) |
| 74 | (Account_id_map.singleton virt_counterparty @@ cents base.amount) | ||
| 75 | ~credit: | ||
| 76 | (Account_id_map.singleton virt_checking_acc @@ cents base.amount) | ||
| 77 | ~labels: | 74 | ~labels: |
| 78 | Labels.( | 75 | Labels.( |
| 79 | empty | 76 | base_labels |
| 80 | |> add (Iban_label Account_tag) base.account | ||
| 81 | |> add (String_label Counterparty_name_tag) | 77 | |> add (String_label Counterparty_name_tag) |
| 82 | details.counterparty_name | 78 | details.counterparty_name |
| 83 | |> add (Iban_label Counterparty_iban_tag) | 79 | |> add (Iban_label Counterparty_iban_tag) |
| @@ -85,14 +81,10 @@ let tx_from_current_acc euc_id (Ingcsv.Tx (base, spec)) = | |||
| 85 | |> add (String_label Desc_tag) details.description) | 81 | |> add (String_label Desc_tag) details.description) |
| 86 | | Recurrent_direct_debit details -> | 82 | | Recurrent_direct_debit details -> |
| 87 | Tx.make ~cleared:(Some base.date) ~commodity_id:euc_id | 83 | Tx.make ~cleared:(Some base.date) ~commodity_id:euc_id |
| 88 | ~debit: | 84 | ~entries:(make_tx_entries ~on_checking:Debit_credit.Credit) |
| 89 | (Account_id_map.singleton virt_counterparty @@ cents base.amount) | ||
| 90 | ~credit: | ||
| 91 | (Account_id_map.singleton virt_checking_acc @@ cents base.amount) | ||
| 92 | ~labels: | 85 | ~labels: |
| 93 | Labels.( | 86 | Labels.( |
| 94 | empty | 87 | base_labels |
| 95 | |> add (Iban_label Account_tag) base.account | ||
| 96 | |> add (Iban_label Counterparty_iban_tag) | 88 | |> add (Iban_label Counterparty_iban_tag) |
| 97 | details.counterparty_iban | 89 | details.counterparty_iban |
| 98 | |> add (String_label Counterparty_name_tag) | 90 | |> add (String_label Counterparty_name_tag) |
| @@ -108,24 +100,18 @@ let tx_from_current_acc euc_id (Ingcsv.Tx (base, spec)) = | |||
| 108 | add (String_label Other_party_tag) other_party) | 100 | add (String_label Other_party_tag) other_party) |
| 109 | | Rounding_savings_deposit details -> | 101 | | Rounding_savings_deposit details -> |
| 110 | Tx.make ~cleared:(Some base.date) ~commodity_id:euc_id | 102 | Tx.make ~cleared:(Some base.date) ~commodity_id:euc_id |
| 111 | ~debit: | 103 | ~entries:(make_tx_entries ~on_checking:Debit_credit.Credit) |
| 112 | (Account_id_map.singleton virt_counterparty @@ cents base.amount) | ||
| 113 | ~credit: | ||
| 114 | (Account_id_map.singleton virt_checking_acc @@ cents base.amount) | ||
| 115 | ~labels: | 104 | ~labels: |
| 116 | Labels.( | 105 | Labels.( |
| 117 | empty | 106 | base_labels |
| 118 | |> add (Unit_label Auto_round_savings_tag) () | 107 | |> add (Unit_label Auto_round_savings_tag) () |
| 119 | |> add (String_label Savings_account_tag) details.savings_account) | 108 | |> add (String_label Savings_account_tag) details.savings_account) |
| 120 | | Deposit details -> | 109 | | Deposit details -> |
| 121 | Tx.make ~cleared:(Some base.date) ~commodity_id:euc_id | 110 | Tx.make ~cleared:(Some base.date) ~commodity_id:euc_id |
| 122 | ~debit: | 111 | ~entries:(make_tx_entries ~on_checking:Debit_credit.Debit) |
| 123 | (Account_id_map.singleton virt_checking_acc @@ cents base.amount) | ||
| 124 | ~credit: | ||
| 125 | (Account_id_map.singleton virt_counterparty @@ cents base.amount) | ||
| 126 | ~labels: | 112 | ~labels: |
| 127 | Labels.( | 113 | Labels.( |
| 128 | empty | 114 | base_labels |
| 129 | |> add (Iban_label Counterparty_iban_tag) | 115 | |> add (Iban_label Counterparty_iban_tag) |
| 130 | details.counterparty_iban | 116 | details.counterparty_iban |
| 131 | |> add (String_label Counterparty_name_tag) | 117 | |> add (String_label Counterparty_name_tag) |
| @@ -134,13 +120,10 @@ let tx_from_current_acc euc_id (Ingcsv.Tx (base, spec)) = | |||
| 134 | |> add (String_label Reference_tag) details.reference) | 120 | |> add (String_label Reference_tag) details.reference) |
| 135 | | Ideal_debit details -> | 121 | | Ideal_debit details -> |
| 136 | Tx.make ~cleared:(Some base.date) ~commodity_id:euc_id | 122 | Tx.make ~cleared:(Some base.date) ~commodity_id:euc_id |
| 137 | ~debit: | 123 | ~entries:(make_tx_entries ~on_checking:Debit_credit.Credit) |
| 138 | (Account_id_map.singleton virt_counterparty @@ cents base.amount) | ||
| 139 | ~credit: | ||
| 140 | (Account_id_map.singleton virt_checking_acc @@ cents base.amount) | ||
| 141 | ~labels: | 124 | ~labels: |
| 142 | Labels.( | 125 | Labels.( |
| 143 | empty | 126 | base_labels |
| 144 | |> add (Iban_label Counterparty_iban_tag) | 127 | |> add (Iban_label Counterparty_iban_tag) |
| 145 | details.counterparty_iban | 128 | details.counterparty_iban |
| 146 | |> add (String_label Counterparty_name_tag) | 129 | |> add (String_label Counterparty_name_tag) |
| @@ -150,13 +133,10 @@ let tx_from_current_acc euc_id (Ingcsv.Tx (base, spec)) = | |||
| 150 | |> add Timestamp_label details.timestamp) | 133 | |> add Timestamp_label details.timestamp) |
| 151 | | Batch_payment details -> | 134 | | Batch_payment details -> |
| 152 | Tx.make ~cleared:(Some base.date) ~commodity_id:euc_id | 135 | Tx.make ~cleared:(Some base.date) ~commodity_id:euc_id |
| 153 | ~debit: | 136 | ~entries:(make_tx_entries ~on_checking:Debit_credit.Debit) |
| 154 | (Account_id_map.singleton virt_counterparty @@ cents base.amount) | ||
| 155 | ~credit: | ||
| 156 | (Account_id_map.singleton virt_checking_acc @@ cents base.amount) | ||
| 157 | ~labels: | 137 | ~labels: |
| 158 | Labels.( | 138 | Labels.( |
| 159 | empty | 139 | base_labels |
| 160 | |> add (Iban_label Counterparty_iban_tag) | 140 | |> add (Iban_label Counterparty_iban_tag) |
| 161 | details.counterparty_iban | 141 | details.counterparty_iban |
| 162 | |> add (String_label Counterparty_name_tag) | 142 | |> add (String_label Counterparty_name_tag) |
| @@ -164,14 +144,6 @@ let tx_from_current_acc euc_id (Ingcsv.Tx (base, spec)) = | |||
| 164 | |> add (String_label Desc_tag) details.description | 144 | |> add (String_label Desc_tag) details.description |
| 165 | |> add (String_label Reference_tag) details.reference) | 145 | |> add (String_label Reference_tag) details.reference) |
| 166 | 146 | ||
| 167 | let ba_from_current_acc (Ingcsv.Tx (base, _)) = | ||
| 168 | { | ||
| 169 | account = virt_checking_acc; | ||
| 170 | amount = Money.of_z base.resulting_balance; | ||
| 171 | labels = Labels.(empty |> add (Iban_label Account_tag) base.account); | ||
| 172 | } | ||
| 173 | |||
| 174 | let les_from_current_acc euc_id tx = | 147 | let les_from_current_acc euc_id tx = |
| 175 | let%map tx' = tx_from_current_acc euc_id tx in | 148 | let%map tx' = tx_from_current_acc euc_id tx in |
| 176 | let ba = ba_from_current_acc tx in | 149 | [ Tx_item tx' ] |
| 177 | [ Bal_assert_item ba; Tx_item tx' ] | ||
| @@ -2,4 +2,11 @@ | |||
| 2 | (name rdcapsis) | 2 | (name rdcapsis) |
| 3 | (preprocess | 3 | (preprocess |
| 4 | (pps ppx_jane)) | 4 | (pps ppx_jane)) |
| 5 | (libraries core zarith dmap delimited_parsing re core_unix.date_unix)) | 5 | (libraries |
| 6 | core | ||
| 7 | bignum.bigint | ||
| 8 | bigdecimal | ||
| 9 | dmap | ||
| 10 | delimited_parsing | ||
| 11 | re | ||
| 12 | core_unix.date_unix)) | ||
diff --git a/lib/iban.ml b/lib/iban.ml index fbea774..9b516c4 100644 --- a/lib/iban.ml +++ b/lib/iban.ml | |||
| @@ -82,7 +82,16 @@ let to_string = Fn.id | |||
| 82 | let of_string s = | 82 | let of_string s = |
| 83 | match make s with | 83 | match make s with |
| 84 | | Some iban -> iban | 84 | | Some iban -> iban |
| 85 | | None -> Printf.failwithf "Iban.of_string: %S" s () | 85 | | None -> Printf.failwithf "Iban.of_string: invalid IBAN %S" s () |
| 86 | 86 | ||
| 87 | let sexp_of_t iban = Sexp.Atom iban | 87 | let sexp_of_t iban = Sexp.Atom iban |
| 88 | |||
| 89 | let t_of_sexp sexp = | ||
| 90 | match sexp with | ||
| 91 | | Sexp.Atom s -> ( | ||
| 92 | match make s with | ||
| 93 | | Some iban -> iban | ||
| 94 | | None -> of_sexp_error "Iban.t_of_sexp: invalid IBAN" sexp) | ||
| 95 | | Sexp.List _ -> of_sexp_error "Iban.t_of_sexp: expected a list" sexp | ||
| 96 | |||
| 88 | let equal = String.equal | 97 | let equal = String.equal |
diff --git a/lib/iban.mli b/lib/iban.mli index fa18a63..3a5698a 100644 --- a/lib/iban.mli +++ b/lib/iban.mli | |||
| @@ -3,7 +3,7 @@ open Prelude | |||
| 3 | type t | 3 | type t |
| 4 | 4 | ||
| 5 | val make : string -> t option | 5 | val make : string -> t option |
| 6 | val sexp_of_t : t -> Sexp.t | ||
| 7 | 6 | ||
| 8 | include Stringable.S with type t := t | 7 | include Stringable.S with type t := t |
| 9 | include Equal.S with type t := t | 8 | include Equal.S with type t := t |
| 9 | include Sexpable.S with type t := t | ||
diff --git a/lib/ingcsv.ml b/lib/ingcsv.ml index f9cd95e..bef9ab9 100644 --- a/lib/ingcsv.ml +++ b/lib/ingcsv.ml | |||
| @@ -1,9 +1,6 @@ | |||
| 1 | open Prelude | 1 | open Prelude |
| 2 | open Result.Let_syntax | 2 | open Result.Let_syntax |
| 3 | 3 | module Debit_credit = Ledger.Debit_credit | |
| 4 | module Debit_credit = struct | ||
| 5 | type t = Debit | Credit [@@deriving string, sexp_of] | ||
| 6 | end | ||
| 7 | 4 | ||
| 8 | module Cents = struct | 5 | module Cents = struct |
| 9 | type t = Z.t | 6 | type t = Z.t |
diff --git a/lib/ledger.ml b/lib/ledger.ml index 84a0146..7805179 100644 --- a/lib/ledger.ml +++ b/lib/ledger.ml | |||
| @@ -1,7 +1,5 @@ | |||
| 1 | open Prelude | 1 | open Prelude |
| 2 | 2 | ||
| 3 | type account_type = Asset | Equity | Liability | Expense | Income | ||
| 4 | |||
| 5 | type tx_type = | 3 | type tx_type = |
| 6 | | Interest_tx | 4 | | Interest_tx |
| 7 | | Online_banking_tx | 5 | | Online_banking_tx |
| @@ -14,11 +12,10 @@ type tx_type = | |||
| 14 | | Direct_debit_tx | 12 | | Direct_debit_tx |
| 15 | | Periodic_tx | 13 | | Periodic_tx |
| 16 | 14 | ||
| 17 | type iban_tag = Account_tag | Counterparty_iban_tag | 15 | type iban_tag = Account_tag | Counterparty_iban_tag [@@deriving compare, sexp] |
| 18 | [@@deriving compare, sexp_of] | ||
| 19 | 16 | ||
| 20 | type unit_tag = Filed_tag | Google_pay_tag | Auto_round_savings_tag | 17 | type unit_tag = Filed_tag | Google_pay_tag | Auto_round_savings_tag |
| 21 | [@@deriving compare, sexp_of] | 18 | [@@deriving compare, sexp] |
| 22 | 19 | ||
| 23 | type string_tag = | 20 | type string_tag = |
| 24 | | Desc_tag | 21 | | Desc_tag |
| @@ -32,7 +29,7 @@ type string_tag = | |||
| 32 | | Terminal_tag | 29 | | Terminal_tag |
| 33 | | Card_seq_no_tag | 30 | | Card_seq_no_tag |
| 34 | | Savings_account_tag | 31 | | Savings_account_tag |
| 35 | [@@deriving compare, sexp_of] | 32 | [@@deriving compare, sexp] |
| 36 | 33 | ||
| 37 | module Label = struct | 34 | module Label = struct |
| 38 | type 'a t = | 35 | type 'a t = |
| @@ -62,29 +59,41 @@ end | |||
| 62 | module Labels = struct | 59 | module Labels = struct |
| 63 | include Dmap.Make (Label) | 60 | include Dmap.Make (Label) |
| 64 | 61 | ||
| 65 | let sexp_of_t m = | 62 | let sexp_of_binding = function |
| 66 | Sexp.List | 63 | | Binding (Iban_label tag, iban) -> |
| 67 | (bindings m | 64 | Sexp.List |
| 68 | |> List.map ~f:(function | 65 | [ |
| 69 | | Binding (Iban_label tag, iban) -> | 66 | Sexp.Atom "iban"; [%sexp_of: iban_tag] tag; [%sexp_of: Iban.t] iban; |
| 70 | Sexp.List | 67 | ] |
| 71 | [ | 68 | | Binding (String_label tag, s) -> |
| 72 | Sexp.Atom "Iban_label"; | 69 | Sexp.List |
| 73 | [%sexp_of: iban_tag] tag; | 70 | [ Sexp.Atom "string"; [%sexp_of: string_tag] tag; Sexp.Atom s ] |
| 74 | [%sexp_of: Iban.t] iban; | 71 | | Binding (Timestamp_label, ts) -> |
| 75 | ] | 72 | Sexp.List [ Sexp.Atom "timestamp"; [%sexp_of: Time_ns_unix.t] ts ] |
| 76 | | Binding (String_label tag, s) -> | 73 | | Binding (Unit_label tag, ()) -> |
| 77 | Sexp.List | 74 | Sexp.List [ Sexp.Atom "unit"; [%sexp_of: unit_tag] tag ] |
| 78 | [ | 75 | |
| 79 | Sexp.Atom "String_label"; | 76 | let binding_of_sexp sexp = |
| 80 | [%sexp_of: string_tag] tag; | 77 | match sexp with |
| 81 | Sexp.Atom s; | 78 | | Sexp.List [ Sexp.Atom "iban"; tag_sexp; iban_sexp ] -> |
| 82 | ] | 79 | Binding |
| 83 | | Binding (Timestamp_label, ts) -> | 80 | ( Iban_label ([%of_sexp: iban_tag] tag_sexp), |
| 84 | Sexp.List | 81 | [%of_sexp: Iban.t] iban_sexp ) |
| 85 | [ Sexp.Atom "Timestamp_label"; [%sexp_of: Time_ns_unix.t] ts ] | 82 | | Sexp.List [ Sexp.Atom "string"; tag_sexp; Sexp.Atom s ] -> |
| 86 | | Binding (Unit_label tag, ()) -> | 83 | Binding (String_label ([%of_sexp: string_tag] tag_sexp), s) |
| 87 | Sexp.List [ Sexp.Atom "Unit_label"; [%sexp_of: unit_tag] tag ])) | 84 | | Sexp.List [ Sexp.Atom "timestamp"; ts_sexp ] -> |
| 85 | Binding (Timestamp_label, [%of_sexp: Time_ns_unix.t] ts_sexp) | ||
| 86 | | Sexp.List [ Sexp.Atom "unit"; tag_sexp ] -> | ||
| 87 | Binding (Unit_label ([%of_sexp: unit_tag] tag_sexp), ()) | ||
| 88 | | _ -> of_sexp_error "Labels.binding_of_sexp: invalid binding" sexp | ||
| 89 | |||
| 90 | let sexp_of_t m = Sexp.List (bindings m |> List.map ~f:sexp_of_binding) | ||
| 91 | |||
| 92 | let t_of_sexp sexp = | ||
| 93 | match sexp with | ||
| 94 | | Sexp.List labels -> | ||
| 95 | Sequence.(of_list labels >>| binding_of_sexp |> to_seq) |> of_seq | ||
| 96 | | Sexp.Atom _ -> of_sexp_error "Labels.t_of_sexp: list needed" sexp | ||
| 88 | end | 97 | end |
| 89 | 98 | ||
| 90 | module Money : sig | 99 | module Money : sig |
| @@ -92,27 +101,33 @@ module Money : sig | |||
| 92 | 101 | ||
| 93 | val equal : t -> t -> bool | 102 | val equal : t -> t -> bool |
| 94 | val compare : t -> t -> int | 103 | val compare : t -> t -> int |
| 95 | val of_z : Z.t -> t | 104 | val of_bigint : Bigint.t -> t |
| 96 | val to_z : t -> Z.t | 105 | val to_bigint : t -> Bigint.t |
| 97 | val ( + ) : t -> t -> t | 106 | val ( + ) : t -> t -> t |
| 98 | val ( - ) : t -> t -> t | 107 | val ( - ) : t -> t -> t |
| 108 | val ( = ) : t -> t -> bool | ||
| 109 | val ( ~$ ) : int -> t | ||
| 99 | val sexp_of_t : t -> Sexp.t | 110 | val sexp_of_t : t -> Sexp.t |
| 100 | end = struct | 111 | end = struct |
| 101 | type t = Z.t [@@deriving sexp_of] | 112 | type t = Bigint.t [@@deriving sexp_of] |
| 102 | |||
| 103 | let equal = Z.equal | ||
| 104 | let compare = Z.compare | ||
| 105 | let of_z = Fn.id | ||
| 106 | let to_z = Fn.id | ||
| 107 | let ( + ) x y = Z.(x + y) | ||
| 108 | let ( - ) x y = Z.(x - y) | ||
| 109 | end | ||
| 110 | 113 | ||
| 111 | type scalar = Amount of Money.t | Rate of Z.t | 114 | let equal = Bigint.equal |
| 112 | [@@deriving equal, compare, sexp_of] | 115 | let compare = Bigint.compare |
| 116 | let of_bigint = Fn.id | ||
| 117 | let to_bigint = Fn.id | ||
| 118 | let ( + ) x y = Bigint.(x + y) | ||
| 119 | let ( - ) x y = Bigint.(x - y) | ||
| 120 | let ( = ) = equal | ||
| 121 | let ( ~$ ) = Fn.compose of_bigint Bigint.of_int | ||
| 122 | end | ||
| 113 | 123 | ||
| 114 | type commodity_id = string | 124 | type commodity_id = string |
| 115 | (* TODO: consider making this UUID *) [@@deriving sexp] | 125 | (* TODO: consider making this UUID *) [@@deriving equal, compare, sexp] |
| 126 | |||
| 127 | type scalar = | ||
| 128 | | Amount of Money.t | ||
| 129 | | Rate of { in_primary_commodity : Money.t; rate : Bigdecimal.t } | ||
| 130 | [@@deriving equal, compare, sexp_of] | ||
| 116 | 131 | ||
| 117 | module Account_id = struct | 132 | module Account_id = struct |
| 118 | type t = string list [@@deriving sexp, compare] | 133 | type t = string list [@@deriving sexp, compare] |
| @@ -135,13 +150,18 @@ type bal_assert = { | |||
| 135 | 150 | ||
| 136 | module Account_id_map = Map.Make (Account_id) | 151 | module Account_id_map = Map.Make (Account_id) |
| 137 | 152 | ||
| 153 | module Debit_credit = struct | ||
| 154 | type t = Debit | Credit [@@deriving string, sexp_of] | ||
| 155 | |||
| 156 | let opposite = function Debit -> Credit | Credit -> Debit | ||
| 157 | end | ||
| 158 | |||
| 138 | module Tx : sig | 159 | module Tx : sig |
| 139 | (* Private because we only want to allow constructing balanced transactions. *) | 160 | (* Private because we only want to allow constructing balanced transactions. *) |
| 140 | type t = private { | 161 | type t = private { |
| 141 | cleared : Date.t option; | 162 | cleared : Date.t option; |
| 142 | commodity_id : commodity_id; | 163 | commodity_id : commodity_id; |
| 143 | debit : scalar Account_id_map.t; | 164 | entries : (Debit_credit.t * scalar * Money.t option) Account_id_map.t; |
| 144 | credit : scalar Account_id_map.t; | ||
| 145 | labels : Labels.t; | 165 | labels : Labels.t; |
| 146 | } | 166 | } |
| 147 | 167 | ||
| @@ -150,8 +170,7 @@ module Tx : sig | |||
| 150 | val make : | 170 | val make : |
| 151 | cleared:Date.t option -> | 171 | cleared:Date.t option -> |
| 152 | commodity_id:commodity_id -> | 172 | commodity_id:commodity_id -> |
| 153 | debit:scalar Account_id_map.t -> | 173 | entries:(Debit_credit.t * scalar * Money.t option) Account_id_map.t -> |
| 154 | credit:scalar Account_id_map.t -> | ||
| 155 | labels:Labels.t -> | 174 | labels:Labels.t -> |
| 156 | (t, error) result | 175 | (t, error) result |
| 157 | 176 | ||
| @@ -160,23 +179,86 @@ end = struct | |||
| 160 | type t = { | 179 | type t = { |
| 161 | cleared : Date.t option; | 180 | cleared : Date.t option; |
| 162 | commodity_id : commodity_id; | 181 | commodity_id : commodity_id; |
| 163 | debit : scalar Account_id_map.t; | 182 | entries : (Debit_credit.t * scalar * Money.t option) Account_id_map.t; |
| 164 | credit : scalar Account_id_map.t; | ||
| 165 | labels : Labels.t; | 183 | labels : Labels.t; |
| 166 | } | 184 | } |
| 167 | [@@deriving sexp_of] | 185 | [@@deriving sexp_of] |
| 168 | 186 | ||
| 169 | type error = Unbalanced | 187 | type error = Unbalanced |
| 170 | 188 | ||
| 171 | (* TODO: check if debits and credits are balanced *) | 189 | let is_balanced entries = |
| 172 | let is_balanced _debits _credits = true | 190 | Map.fold entries |
| 191 | ~init:Money.(~$0, ~$0) | ||
| 192 | ~f:(fun ~key:_ ~data:(type_, scalar, _oassert) (ds, cs) -> | ||
| 193 | let m = | ||
| 194 | match scalar with | ||
| 195 | | Amount m -> m | ||
| 196 | | Rate { in_primary_commodity = m; _ } -> m | ||
| 197 | in | ||
| 198 | match type_ with | ||
| 199 | | Debit_credit.Debit -> Money.(ds + m, cs) | ||
| 200 | | Debit_credit.Credit -> Money.(ds, cs + m)) | ||
| 201 | |> fun (ds, cs) -> Money.(ds = cs) | ||
| 173 | 202 | ||
| 174 | let make ~cleared ~commodity_id ~debit ~credit ~labels = | 203 | let make ~cleared ~commodity_id ~entries ~labels = |
| 175 | if not (is_balanced debit credit) then Error Unbalanced | 204 | if not (is_balanced entries) then Error Unbalanced |
| 176 | else Ok { cleared; commodity_id; debit; credit; labels } | 205 | else Ok { cleared; commodity_id; entries; labels } |
| 177 | end | 206 | end |
| 178 | 207 | ||
| 179 | type item = Tx_item of Tx.t | Bal_assert_item of bal_assert | 208 | type item = |
| 209 | | Tx_item of Tx.t | ||
| 210 | | Bal_assert_item of bal_assert (*| Account_decl_item of account_decl*) | ||
| 180 | [@@deriving sexp_of] | 211 | [@@deriving sexp_of] |
| 181 | 212 | ||
| 182 | type t = item list [@@deriving sexp_of] | 213 | type t = item list [@@deriving sexp_of] |
| 214 | |||
| 215 | module Account = struct | ||
| 216 | type global_type = Asset | Equity | Liability | Expense | Income | ||
| 217 | [@@deriving compare, sexp] | ||
| 218 | |||
| 219 | type asset | ||
| 220 | type global | ||
| 221 | |||
| 222 | type 'a subcategory = | ||
| 223 | | Asset : asset subcategory option -> global subcategory | ||
| 224 | | Checking : asset subcategory | ||
| 225 | |||
| 226 | type 'a t = Sub of ('a, 'a t) category String.Map.t | ||
| 227 | |||
| 228 | let world : global t = | ||
| 229 | Sub | ||
| 230 | (String.Map.of_alist_exn [ ("Assets", Asset (Some ( | ||
| 231 | String.Map.of_alist_exn [ | ||
| 232 | ("Checking", Checking) | ||
| 233 | ] | ||
| 234 | ))) ]) | ||
| 235 | end | ||
| 236 | |||
| 237 | (* | ||
| 238 | module World = struct | ||
| 239 | type t = (commodity_id * Money.t) Account_id_map.t | ||
| 240 | |||
| 241 | let empty : t = Account_id_map.empty | ||
| 242 | |||
| 243 | let apply_tx_entry_base aid primary_commodity debit_credit scalar = | ||
| 244 | let amount = Scalar.to_amount ~commodity:primary_commodity scalar in | ||
| 245 | Map.update aid ~f:(function | ||
| 246 | | None -> | ||
| 247 | |||
| 248 | (* | ||
| 249 | let assert_bal aid sc world = | ||
| 250 | |||
| 251 | let apply_tx_entry aid (dc, sc, oassert) world = *) | ||
| 252 | |||
| 253 | let apply_tx (tx : Tx.t) world = | ||
| 254 | Map.fold tx.entries ~init:world ~f:(fun ~key:account_id ~data:(type_, scalar, _oassert) world -> | ||
| 255 | |||
| 256 | |||
| 257 | ) | ||
| 258 | |||
| 259 | let apply : item -> t -> t = function | ||
| 260 | | Tx_item tx -> apply_tx tx | ||
| 261 | | Bal_assert_item ba -> apply_ba ba | ||
| 262 | end *) | ||
| 263 | |||
| 264 | let make = Fn.id | ||
diff --git a/lib/ledger.mli b/lib/ledger.mli new file mode 100644 index 0000000..0b8e383 --- /dev/null +++ b/lib/ledger.mli | |||
| @@ -0,0 +1,133 @@ | |||
| 1 | open Prelude | ||
| 2 | |||
| 3 | (* | ||
| 4 | type account_type = Asset | Equity | Liability | Expense | Income | ||
| 5 | [@@deriving compare, sexp]*) | ||
| 6 | |||
| 7 | type tx_type = | ||
| 8 | | Interest_tx | ||
| 9 | | Online_banking_tx | ||
| 10 | | Recurrent_direct_tx | ||
| 11 | | Payment_terminal_tx | ||
| 12 | | Cash_payment_tx | ||
| 13 | | Atm_tx | ||
| 14 | | Auto_save_rounding_tx | ||
| 15 | | Batch_tx | ||
| 16 | | Direct_debit_tx | ||
| 17 | | Periodic_tx | ||
| 18 | |||
| 19 | type iban_tag = Account_tag | Counterparty_iban_tag [@@deriving compare, sexp] | ||
| 20 | |||
| 21 | type unit_tag = Filed_tag | Google_pay_tag | Auto_round_savings_tag | ||
| 22 | [@@deriving compare, sexp] | ||
| 23 | |||
| 24 | type string_tag = | ||
| 25 | | Desc_tag | ||
| 26 | | User_tag | ||
| 27 | | Counterparty_name_tag | ||
| 28 | | Reference_tag | ||
| 29 | | Mandate_id_tag | ||
| 30 | | Creditor_id_tag | ||
| 31 | | Other_party_tag | ||
| 32 | | Transaction_tag | ||
| 33 | | Terminal_tag | ||
| 34 | | Card_seq_no_tag | ||
| 35 | | Savings_account_tag | ||
| 36 | [@@deriving compare, sexp] | ||
| 37 | |||
| 38 | module Label : sig | ||
| 39 | type 'a t = | ||
| 40 | | Iban_label : iban_tag -> Iban.t t | ||
| 41 | | String_label : string_tag -> string t | ||
| 42 | | Timestamp_label : Time_ns.t t | ||
| 43 | | Unit_label : unit_tag -> unit t | ||
| 44 | |||
| 45 | val int_to_cmp : int -> ('a, 'a) Dmap.cmp | ||
| 46 | val compare : 'a1 'a2. 'a1 t -> 'a2 t -> ('a1, 'a2) Dmap.cmp | ||
| 47 | end | ||
| 48 | |||
| 49 | module Labels : sig | ||
| 50 | include Dmap.S with type 'a key = 'a Label.t | ||
| 51 | |||
| 52 | val sexp_of_binding : binding -> Sexp.t | ||
| 53 | val binding_of_sexp : Sexp.t -> binding | ||
| 54 | |||
| 55 | include Sexpable.S with type t := t | ||
| 56 | end | ||
| 57 | |||
| 58 | module Money : sig | ||
| 59 | type t | ||
| 60 | |||
| 61 | val equal : t -> t -> bool | ||
| 62 | val compare : t -> t -> int | ||
| 63 | val of_bigint : Bigint.t -> t | ||
| 64 | val to_bigint : t -> Bigint.t | ||
| 65 | val ( + ) : t -> t -> t | ||
| 66 | val ( - ) : t -> t -> t | ||
| 67 | val ( = ) : t -> t -> bool | ||
| 68 | val ( ~$ ) : int -> t | ||
| 69 | val sexp_of_t : t -> Sexp.t | ||
| 70 | end | ||
| 71 | |||
| 72 | type commodity_id = string | ||
| 73 | (* TODO: consider making this UUID *) [@@deriving equal, compare, sexp] | ||
| 74 | |||
| 75 | type scalar = | ||
| 76 | | Amount of Money.t | ||
| 77 | | Rate of { in_primary_commodity : Money.t; rate : Bigdecimal.t } | ||
| 78 | [@@deriving equal, compare, sexp_of] | ||
| 79 | |||
| 80 | module Account_id : sig | ||
| 81 | type t = string list [@@deriving sexp, compare] | ||
| 82 | end | ||
| 83 | |||
| 84 | type account = { | ||
| 85 | id : Account_id.t; | ||
| 86 | description : string list; | ||
| 87 | commodity_id : commodity_id; | ||
| 88 | balance : Money.t; | ||
| 89 | } | ||
| 90 | [@@deriving sexp_of] | ||
| 91 | |||
| 92 | type bal_assert = { | ||
| 93 | account : Account_id.t; | ||
| 94 | amount : Money.t; | ||
| 95 | labels : Labels.t; | ||
| 96 | } | ||
| 97 | [@@deriving sexp_of] | ||
| 98 | |||
| 99 | module Account_id_map : Map.S with type Key.t = Account_id.t | ||
| 100 | |||
| 101 | module Debit_credit : sig | ||
| 102 | type t = Debit | Credit [@@deriving string, sexp_of] | ||
| 103 | |||
| 104 | val opposite : t -> t | ||
| 105 | end | ||
| 106 | |||
| 107 | module Tx : sig | ||
| 108 | (* Private because we only want to allow constructing balanced transactions. *) | ||
| 109 | type t = private { | ||
| 110 | cleared : Date.t option; | ||
| 111 | commodity_id : commodity_id; | ||
| 112 | entries : (Debit_credit.t * scalar * Money.t option) Account_id_map.t; | ||
| 113 | labels : Labels.t; | ||
| 114 | } | ||
| 115 | |||
| 116 | type error = Unbalanced | ||
| 117 | |||
| 118 | val make : | ||
| 119 | cleared:Date.t option -> | ||
| 120 | commodity_id:commodity_id -> | ||
| 121 | entries:(Debit_credit.t * scalar * Money.t option) Account_id_map.t -> | ||
| 122 | labels:Labels.t -> | ||
| 123 | (t, error) result | ||
| 124 | |||
| 125 | val sexp_of_t : t -> Sexp.t | ||
| 126 | end | ||
| 127 | |||
| 128 | type item = Tx_item of Tx.t | Bal_assert_item of bal_assert | ||
| 129 | [@@deriving sexp_of] | ||
| 130 | |||
| 131 | type t [@@deriving sexp_of] | ||
| 132 | |||
| 133 | val make : item list -> t | ||
diff --git a/lib/preledger.ml b/lib/preledger.ml new file mode 100644 index 0000000..05f9e36 --- /dev/null +++ b/lib/preledger.ml | |||
| @@ -0,0 +1,217 @@ | |||
| 1 | open Prelude | ||
| 2 | module Debit_credit = Ledger.Debit_credit | ||
| 3 | |||
| 4 | type tx_type = | ||
| 5 | | Interest_tx | ||
| 6 | | Online_banking_tx | ||
| 7 | | Recurrent_direct_tx | ||
| 8 | | Payment_terminal_tx | ||
| 9 | | Cash_payment_tx | ||
| 10 | | Atm_tx | ||
| 11 | | Auto_save_rounding_tx | ||
| 12 | | Batch_tx | ||
| 13 | | Direct_debit_tx | ||
| 14 | | Periodic_tx | ||
| 15 | [@@deriving compare, sexp] | ||
| 16 | |||
| 17 | type iban_tag = Account_tag | Counterparty_iban_tag [@@deriving compare, sexp] | ||
| 18 | |||
| 19 | type unit_tag = Filed_tag | Google_pay_tag | Auto_round_savings_tag | ||
| 20 | [@@deriving compare, sexp] | ||
| 21 | |||
| 22 | type string_tag = | ||
| 23 | | Desc_tag | ||
| 24 | | User_tag | ||
| 25 | | Counterparty_name_tag | ||
| 26 | | Reference_tag | ||
| 27 | | Mandate_id_tag | ||
| 28 | | Creditor_id_tag | ||
| 29 | | Other_party_tag | ||
| 30 | | Transaction_tag | ||
| 31 | | Terminal_tag | ||
| 32 | | Card_seq_no_tag | ||
| 33 | | Savings_account_tag | ||
| 34 | [@@deriving compare, sexp] | ||
| 35 | |||
| 36 | module Label = struct | ||
| 37 | type 'a t = | ||
| 38 | | Iban_label : iban_tag -> Iban.t t | ||
| 39 | | String_label : string_tag -> string t | ||
| 40 | | Timestamp_label : Time_ns.t t | ||
| 41 | | Tx_type_label : tx_type t | ||
| 42 | | Unit_label : unit_tag -> unit t | ||
| 43 | |||
| 44 | let int_to_cmp x : ('a, 'a) Dmap.cmp = | ||
| 45 | if x < 0 then Lt else if x > 0 then Gt else Eq | ||
| 46 | |||
| 47 | let compare (type a1 a2) (v1 : a1 t) (v2 : a2 t) : (a1, a2) Dmap.cmp = | ||
| 48 | match (v1, v2) with | ||
| 49 | | Iban_label t1, Iban_label t2 -> int_to_cmp @@ [%compare: iban_tag] t1 t2 | ||
| 50 | | String_label t1, String_label t2 -> | ||
| 51 | int_to_cmp @@ [%compare: string_tag] t1 t2 | ||
| 52 | | Timestamp_label, Timestamp_label -> Eq | ||
| 53 | | Tx_type_label, Tx_type_label -> Eq | ||
| 54 | | Unit_label t1, Unit_label t2 -> int_to_cmp @@ [%compare: unit_tag] t1 t2 | ||
| 55 | | Iban_label _, _ -> Lt | ||
| 56 | | String_label _, Iban_label _ -> Gt | ||
| 57 | | String_label _, _ -> Lt | ||
| 58 | | Timestamp_label, Unit_label _ -> Lt | ||
| 59 | | Timestamp_label, Tx_type_label -> Lt | ||
| 60 | | Timestamp_label, _ -> Gt | ||
| 61 | | Tx_type_label, Unit_label _ -> Lt | ||
| 62 | | Tx_type_label, _ -> Gt | ||
| 63 | | Unit_label _, _ -> Gt | ||
| 64 | end | ||
| 65 | |||
| 66 | module Labels = struct | ||
| 67 | include Dmap.Make (Label) | ||
| 68 | |||
| 69 | let sexp_of_binding = function | ||
| 70 | | Binding (Iban_label tag, iban) -> | ||
| 71 | Sexp.List | ||
| 72 | [ | ||
| 73 | Sexp.Atom "iban"; [%sexp_of: iban_tag] tag; [%sexp_of: Iban.t] iban; | ||
| 74 | ] | ||
| 75 | | Binding (String_label tag, s) -> | ||
| 76 | Sexp.List | ||
| 77 | [ Sexp.Atom "string"; [%sexp_of: string_tag] tag; Sexp.Atom s ] | ||
| 78 | | Binding (Timestamp_label, ts) -> | ||
| 79 | Sexp.List [ Sexp.Atom "timestamp"; [%sexp_of: Time_ns_unix.t] ts ] | ||
| 80 | | Binding (Tx_type_label, type_) -> | ||
| 81 | Sexp.List [ Sexp.Atom "tx_type"; [%sexp_of: tx_type] type_ ] | ||
| 82 | | Binding (Unit_label tag, ()) -> | ||
| 83 | Sexp.List [ Sexp.Atom "unit"; [%sexp_of: unit_tag] tag ] | ||
| 84 | |||
| 85 | let binding_of_sexp sexp = | ||
| 86 | match sexp with | ||
| 87 | | Sexp.List [ Sexp.Atom "iban"; tag_sexp; iban_sexp ] -> | ||
| 88 | Binding | ||
| 89 | ( Iban_label ([%of_sexp: iban_tag] tag_sexp), | ||
| 90 | [%of_sexp: Iban.t] iban_sexp ) | ||
| 91 | | Sexp.List [ Sexp.Atom "string"; tag_sexp; Sexp.Atom s ] -> | ||
| 92 | Binding (String_label ([%of_sexp: string_tag] tag_sexp), s) | ||
| 93 | | Sexp.List [ Sexp.Atom "timestamp"; ts_sexp ] -> | ||
| 94 | Binding (Timestamp_label, [%of_sexp: Time_ns_unix.t] ts_sexp) | ||
| 95 | | Sexp.List [ Sexp.Atom "tx_type"; type_sexp ] -> | ||
| 96 | Binding (Tx_type_label, [%of_sexp: tx_type] type_sexp) | ||
| 97 | | Sexp.List [ Sexp.Atom "unit"; tag_sexp ] -> | ||
| 98 | Binding (Unit_label ([%of_sexp: unit_tag] tag_sexp), ()) | ||
| 99 | | _ -> of_sexp_error "Labels.binding_of_sexp: invalid binding" sexp | ||
| 100 | |||
| 101 | let sexp_of_t m = Sexp.List (bindings m |> List.map ~f:sexp_of_binding) | ||
| 102 | |||
| 103 | let t_of_sexp sexp = | ||
| 104 | match sexp with | ||
| 105 | | Sexp.List labels -> | ||
| 106 | Sequence.(of_list labels >>| binding_of_sexp |> to_seq) |> of_seq | ||
| 107 | | Sexp.Atom _ -> of_sexp_error "Labels.t_of_sexp: list needed" sexp | ||
| 108 | end | ||
| 109 | |||
| 110 | module Money : sig | ||
| 111 | type t | ||
| 112 | |||
| 113 | val equal : t -> t -> bool | ||
| 114 | val compare : t -> t -> int | ||
| 115 | val of_z : Z.t -> t | ||
| 116 | val to_z : t -> Z.t | ||
| 117 | val ( + ) : t -> t -> t | ||
| 118 | val ( - ) : t -> t -> t | ||
| 119 | val ( = ) : t -> t -> bool | ||
| 120 | val ( ~$ ) : int -> t | ||
| 121 | val sexp_of_t : t -> Sexp.t | ||
| 122 | end = struct | ||
| 123 | type t = Z.t [@@deriving sexp_of] | ||
| 124 | |||
| 125 | let equal = Z.equal | ||
| 126 | let compare = Z.compare | ||
| 127 | let of_z = Fn.id | ||
| 128 | let to_z = Fn.id | ||
| 129 | let ( + ) x y = Z.(x + y) | ||
| 130 | let ( - ) x y = Z.(x - y) | ||
| 131 | let ( = ) = equal | ||
| 132 | let ( ~$ ) = Fn.compose of_z Z.of_int | ||
| 133 | end | ||
| 134 | |||
| 135 | (* TODO: make rate a decimal *) | ||
| 136 | type scalar = | ||
| 137 | | Amount of Money.t | ||
| 138 | | Rate of { in_primary_commodity : Money.t; rate : Z.t } | ||
| 139 | [@@deriving equal, compare, sexp_of] | ||
| 140 | |||
| 141 | type commodity_id = string | ||
| 142 | (* TODO: consider making this UUID *) [@@deriving sexp] | ||
| 143 | |||
| 144 | module Account_id = struct | ||
| 145 | type t = string list [@@deriving sexp, compare] | ||
| 146 | end | ||
| 147 | |||
| 148 | type account = { | ||
| 149 | id : Account_id.t; | ||
| 150 | description : string list; | ||
| 151 | commodity_id : commodity_id; | ||
| 152 | balance : Money.t; | ||
| 153 | } | ||
| 154 | [@@deriving sexp_of] | ||
| 155 | |||
| 156 | type bal_assert = { | ||
| 157 | account : Account_id.t; | ||
| 158 | amount : Money.t; | ||
| 159 | labels : Labels.t; | ||
| 160 | } | ||
| 161 | [@@deriving sexp_of] | ||
| 162 | |||
| 163 | module Account_id_map = Map.Make (Account_id) | ||
| 164 | |||
| 165 | module Tx : sig | ||
| 166 | (* Private because we only want to allow constructing balanced transactions. *) | ||
| 167 | type t = private { | ||
| 168 | cleared : Date.t option; | ||
| 169 | commodity_id : commodity_id; | ||
| 170 | entries : (Debit_credit.t * scalar * Money.t option) Account_id_map.t; | ||
| 171 | labels : Labels.t; | ||
| 172 | } | ||
| 173 | |||
| 174 | type error = Unbalanced | ||
| 175 | |||
| 176 | val make : | ||
| 177 | cleared:Date.t option -> | ||
| 178 | commodity_id:commodity_id -> | ||
| 179 | entries:(Debit_credit.t * scalar * Money.t option) Account_id_map.t -> | ||
| 180 | labels:Labels.t -> | ||
| 181 | (t, error) result | ||
| 182 | |||
| 183 | val sexp_of_t : t -> Sexp.t | ||
| 184 | end = struct | ||
| 185 | type t = { | ||
| 186 | cleared : Date.t option; | ||
| 187 | commodity_id : commodity_id; | ||
| 188 | entries : (Debit_credit.t * scalar * Money.t option) Account_id_map.t; | ||
| 189 | labels : Labels.t; | ||
| 190 | } | ||
| 191 | [@@deriving sexp_of] | ||
| 192 | |||
| 193 | type error = Unbalanced | ||
| 194 | |||
| 195 | let is_balanced entries = | ||
| 196 | Map.fold entries | ||
| 197 | ~init:Money.(~$0, ~$0) | ||
| 198 | ~f:(fun ~key:_ ~data:(type_, scalar, _oassert) (ds, cs) -> | ||
| 199 | let m = | ||
| 200 | match scalar with | ||
| 201 | | Amount m -> m | ||
| 202 | | Rate { in_primary_commodity = m; _ } -> m | ||
| 203 | in | ||
| 204 | match type_ with | ||
| 205 | | Debit_credit.Debit -> Money.(ds + m, cs) | ||
| 206 | | Debit_credit.Credit -> Money.(ds, cs + m)) | ||
| 207 | |> fun (ds, cs) -> Money.(ds = cs) | ||
| 208 | |||
| 209 | let make ~cleared ~commodity_id ~entries ~labels = | ||
| 210 | if not (is_balanced entries) then Error Unbalanced | ||
| 211 | else Ok { cleared; commodity_id; entries; labels } | ||
| 212 | end | ||
| 213 | |||
| 214 | type item = Tx_item of Tx.t | Bal_assert_item of bal_assert | ||
| 215 | [@@deriving sexp_of] | ||
| 216 | |||
| 217 | type t = item list [@@deriving sexp_of] | ||