diff options
| -rw-r--r-- | lib/ledger.ml | 762 |
1 files changed, 384 insertions, 378 deletions
diff --git a/lib/ledger.ml b/lib/ledger.ml index 87f3ead..9d315ae 100644 --- a/lib/ledger.ml +++ b/lib/ledger.ml | |||
| @@ -182,7 +182,7 @@ type scalar = | |||
| 182 | | Rate of { in_primary_commodity : Money.Amount.t; rate : Bigdecimal.t } | 182 | | Rate of { in_primary_commodity : Money.Amount.t; rate : Bigdecimal.t } |
| 183 | [@@deriving equal, compare, sexp_of] *) | 183 | [@@deriving equal, compare, sexp_of] *) |
| 184 | 184 | ||
| 185 | module Account_structure0 = struct | 185 | module Account_structure = struct |
| 186 | module Categories = struct | 186 | module Categories = struct |
| 187 | (* The five top-level categories *) | 187 | (* The five top-level categories *) |
| 188 | type asset [@@deriving sexp_of] | 188 | type asset [@@deriving sexp_of] |
| @@ -198,11 +198,35 @@ module Account_structure0 = struct | |||
| 198 | type final [@@deriving sexp_of] | 198 | type final [@@deriving sexp_of] |
| 199 | end | 199 | end |
| 200 | 200 | ||
| 201 | module type Scaffold = sig | 201 | module type S = sig |
| 202 | type 'a t [@@deriving sexp_of] | 202 | type 'a t [@@deriving sexp_of] |
| 203 | |||
| 204 | type 'a f = | ||
| 205 | | Accounts_payable : Categories.final f t -> Categories.liability f | ||
| 206 | | Accounts_receivable : Categories.final f t -> Categories.asset f | ||
| 207 | | Bank : Categories.bank f t -> Categories.asset f | ||
| 208 | | Cash : Categories.final f t -> Categories.asset f | ||
| 209 | | Credit : Categories.final f t -> Categories.liability f | ||
| 210 | | Mutual_fund : Categories.final f t -> Categories.asset f | ||
| 211 | | Stock : Categories.final f t -> Categories.asset f | ||
| 212 | | Savings : Categories.final f t -> Categories.bank f | ||
| 213 | | Checking : Categories.final f t -> Categories.bank f | ||
| 214 | [@@deriving sexp_of] | ||
| 215 | |||
| 216 | type t0 = | ||
| 217 | | Asset of Categories.asset f t | ||
| 218 | | Equity of Categories.equity f t | ||
| 219 | | Expense of Categories.expense f t | ||
| 220 | | Income of Categories.income f t | ||
| 221 | | Liability of Categories.liability f t | ||
| 222 | [@@deriving sexp_of] | ||
| 203 | end | 223 | end |
| 204 | 224 | ||
| 205 | module Make (F : Scaffold) = struct | 225 | module Make (F : sig |
| 226 | type 'a t [@@deriving sexp_of] | ||
| 227 | end) : S with type 'a t = 'a F.t = struct | ||
| 228 | include F | ||
| 229 | |||
| 206 | type 'a f = | 230 | type 'a f = |
| 207 | | Accounts_payable : Categories.final f F.t -> Categories.liability f | 231 | | Accounts_payable : Categories.final f F.t -> Categories.liability f |
| 208 | | Accounts_receivable : Categories.final f F.t -> Categories.asset f | 232 | | Accounts_receivable : Categories.final f F.t -> Categories.asset f |
| @@ -225,40 +249,35 @@ module Account_structure0 = struct | |||
| 225 | end | 249 | end |
| 226 | 250 | ||
| 227 | module Gen_f_cons = struct | 251 | module Gen_f_cons = struct |
| 228 | module type S = sig | ||
| 229 | type inner | ||
| 230 | type outer | ||
| 231 | |||
| 232 | module Specialize : functor | ||
| 233 | (F : Scaffold) | ||
| 234 | (G : module type of Make (F)) | ||
| 235 | -> sig | ||
| 236 | val cons : inner G.f F.t -> outer G.f | ||
| 237 | end | ||
| 238 | end | ||
| 239 | |||
| 240 | module Accounts_payable = struct | 252 | module Accounts_payable = struct |
| 241 | type outer = Categories.liability | 253 | type outer = Categories.liability |
| 242 | type inner = Categories.final | 254 | type inner = Categories.final |
| 243 | 255 | ||
| 244 | module Specialize (F : Scaffold) (G : module type of Make (F)) = struct | 256 | module Specialize (G : S) = struct |
| 245 | let cons v = G.Accounts_payable v | 257 | let cons v = G.Accounts_payable v |
| 246 | end | 258 | end |
| 259 | end | ||
| 260 | |||
| 261 | module type S = sig | ||
| 262 | type inner | ||
| 263 | type outer | ||
| 264 | |||
| 265 | module Specialize : functor (G : S) -> sig | ||
| 266 | val cons : inner G.f G.t -> outer G.f | ||
| 247 | end | 267 | end |
| 248 | end | 268 | end |
| 269 | end | ||
| 249 | 270 | ||
| 250 | module Visitor | 271 | module Visitor |
| 251 | (F : Scaffold) | 272 | (G : S) |
| 252 | (G : | 273 | (Acc : sig |
| 253 | module type of Make (F)) | 274 | type 'a t |
| 254 | (Acc : sig | 275 | end) = |
| 255 | type 'a t | ||
| 256 | end) = | ||
| 257 | struct | 276 | struct |
| 258 | type nonrec 'outer t = { | 277 | type nonrec 'outer t = { |
| 259 | car : | 278 | car : |
| 260 | 'inner. | 279 | 'inner. |
| 261 | 'inner G.f F.t -> | 280 | 'inner G.f G.t -> |
| 262 | (module Gen_f_cons.S with type inner = 'inner and type outer = 'outer) -> | 281 | (module Gen_f_cons.S with type inner = 'inner and type outer = 'outer) -> |
| 263 | 'outer Acc.t; | 282 | 'outer Acc.t; |
| 264 | } | 283 | } |
| @@ -278,249 +297,236 @@ module Account_structure0 = struct | |||
| 278 | | Checking v -> f.car v (fun inner -> H.Checking inner) *) | 297 | | Checking v -> f.car v (fun inner -> H.Checking inner) *) |
| 279 | end | 298 | end |
| 280 | 299 | ||
| 281 | module Basic_visitor (F : Scaffold) (G : module type of Make (F)) = struct | 300 | module Basic_visitor (G : S) = struct |
| 282 | type nonrec 'b t = { car : 'a. 'a G.f F.t -> 'b } | 301 | type nonrec 'b t = { car : 'a. 'a G.f G.t -> 'b } |
| 283 | 302 | ||
| 284 | let visit (type b c) (f : c t) : b G.f -> c = | 303 | let visit (type b c) (f : c t) : b G.f -> c = |
| 285 | let module Inst = | 304 | let module Inst = |
| 286 | Visitor (F) (G) | 305 | Visitor |
| 306 | (G) | ||
| 287 | (struct | 307 | (struct |
| 288 | type 'a t = c | 308 | type 'a t = c |
| 289 | end) | 309 | end) |
| 290 | in | 310 | in |
| 291 | Inst.visit { car = (fun v _cons -> f.car v) } | 311 | Inst.visit { car = (fun v _cons -> f.car v) } |
| 292 | end | 312 | end |
| 293 | end | 313 | end |
| 294 | 314 | ||
| 295 | module Account_type = struct | 315 | module Account_type = struct |
| 296 | type 'a elem = Leaf | Node of 'a [@@deriving sexp_of] | 316 | type 'a elem = Leaf | Node of 'a [@@deriving sexp_of] |
| 297 | 317 | ||
| 298 | module Scaffold = struct | 318 | include Account_structure.Make (struct |
| 299 | type 'a t = 'a elem [@@deriving sexp_of] | 319 | type 'a t = 'a elem [@@deriving sexp_of] |
| 300 | end | 320 | end) |
| 321 | end | ||
| 301 | 322 | ||
| 302 | include Account_structure0.Make (Scaffold) | 323 | module Typed_account_path = struct |
| 303 | end | 324 | type 'a elem = Leaf | Node of string * 'a | Ind of string * 'a elem |
| 325 | [@@deriving sexp_of] | ||
| 304 | 326 | ||
| 305 | module Account_structure (F : Account_structure0.Scaffold) = struct | 327 | include Account_structure.Make (struct |
| 306 | module Structure = Account_structure0.Make (F) | 328 | type 'a t = 'a elem [@@deriving sexp_of] |
| 307 | include Structure | 329 | end) |
| 308 | 330 | end | |
| 309 | module Mapper = struct | ||
| 310 | type nonrec 'b t = { | ||
| 311 | car : | ||
| 312 | 'a. | ||
| 313 | 'a f F.t -> | ||
| 314 | ('a Account_type.f Account_type.elem -> Account_type.t0) -> | ||
| 315 | ('b * 'a f F.t) option; | ||
| 316 | } | ||
| 317 | |||
| 318 | let map (type b c) (f : c t) (mkt : b Account_type.f -> Account_type.t0) : | ||
| 319 | b f -> (c * b f) option = | ||
| 320 | let module Inst = | ||
| 321 | Account_structure0.Visitor (F) (Structure) | ||
| 322 | (struct | ||
| 323 | type 'b t = (c * 'b f) option | ||
| 324 | end) | ||
| 325 | in | ||
| 326 | Inst.visit | ||
| 327 | { | ||
| 328 | car = | ||
| 329 | (fun (type inner) | ||
| 330 | v | ||
| 331 | (module Gen_cons : Account_structure0.Gen_f_cons.S | ||
| 332 | with type inner = inner | ||
| 333 | and type outer = b) | ||
| 334 | -> | ||
| 335 | let open Option.Let_syntax in | ||
| 336 | let module Type_cons = | ||
| 337 | Gen_cons.Specialize (Account_type.Scaffold) (Account_type) | ||
| 338 | in | ||
| 339 | let module Own_cons = Gen_cons.Specialize (F) (Structure) in | ||
| 340 | let%map c, v' = f.car v (fun el -> mkt (Type_cons.cons el)) in | ||
| 341 | (c, Own_cons.cons v')); | ||
| 342 | } | ||
| 343 | end | ||
| 344 | end | ||
| 345 | 331 | ||
| 346 | module Typed_account_path = struct | 332 | module Account_path = struct |
| 347 | type 'a elem = Leaf | Node of string * 'a | Ind of string * 'a elem | 333 | type t = string list [@@deriving compare, sexp] |
| 348 | [@@deriving sexp_of] | ||
| 349 | 334 | ||
| 350 | include Account_structure (struct | 335 | module Map = Map.Make (struct |
| 351 | type 'a t = 'a elem [@@deriving sexp_of] | 336 | type nonrec t = t [@@deriving compare, sexp] |
| 352 | end) | 337 | end) |
| 353 | end | 338 | end |
| 354 | 339 | ||
| 355 | module Account_path = struct | 340 | module Account_hierarchy = struct |
| 356 | type t = string list [@@deriving compare, sexp] | 341 | (* The contents of an account of category 'a *) |
| 342 | type 'a core = | ||
| 343 | (* Comprises of subaccounts of its subcategories *) | ||
| 344 | | Node of 'a String.Map.t | ||
| 345 | (* Comprises of subaccounts of its own category *) | ||
| 346 | | Ind of 'a account String.Map.t | ||
| 347 | (* Has no subaccounts, has a balance in a certain commodity *) | ||
| 348 | | Leaf of Commodity_id.t * Money.Diff.t | ||
| 349 | [@@deriving sexp_of] | ||
| 357 | 350 | ||
| 358 | module Map = Map.Make (struct | 351 | and extra = { description : String.t } [@@deriving sexp_of] |
| 359 | type nonrec t = t [@@deriving compare, sexp] | 352 | and 'a account = extra * 'a core |
| 360 | end) | ||
| 361 | end | ||
| 362 | 353 | ||
| 363 | module Account_hierarchy = struct | 354 | module Structure = Account_structure.Make (struct |
| 364 | (* The contents of an account of category 'a *) | 355 | type 'a t = 'a account [@@deriving sexp_of] |
| 365 | type 'a core = | 356 | end) |
| 366 | (* Comprises of subaccounts of its subcategories *) | ||
| 367 | | Node of 'a String.Map.t | ||
| 368 | (* Comprises of subaccounts of its own category *) | ||
| 369 | | Ind of 'a account String.Map.t | ||
| 370 | (* Has no subaccounts, has a balance in a certain commodity *) | ||
| 371 | | Leaf of Commodity_id.t * Money.Diff.t | ||
| 372 | [@@deriving sexp_of] | ||
| 373 | 357 | ||
| 374 | and extra = { description : String.t } [@@deriving sexp_of] | 358 | (* All accounts *) |
| 375 | and 'a account = extra * 'a core | 359 | type world = Structure.t0 String.Map.t |
| 376 | 360 | ||
| 377 | module Scaffold = struct | 361 | module Mapper = struct |
| 378 | type 'a t = 'a account [@@deriving sexp_of] | 362 | type nonrec 'b t = { |
| 379 | end | 363 | car : |
| 364 | 'a. | ||
| 365 | 'a Structure.f account -> | ||
| 366 | ('a Account_type.f Account_type.elem -> Account_type.t0) -> | ||
| 367 | ('b * 'a Structure.f account) option; | ||
| 368 | } | ||
| 380 | 369 | ||
| 381 | module Structure = Account_structure (Scaffold) | 370 | let map (type b c) (f : c t) (mkt : b Account_type.f -> Account_type.t0) : |
| 382 | 371 | b Structure.f -> (c * b Structure.f) option = | |
| 383 | (* All accounts *) | 372 | let module Inst = |
| 384 | type world = Structure.t0 String.Map.t | 373 | Account_structure.Visitor |
| 385 | 374 | (Structure) | |
| 386 | let rec unsafe_alter_aux (subaid : Account_path.t) | 375 | (struct |
| 387 | (f : | 376 | type 'b t = (c * 'b Structure.f) option |
| 388 | Account_type.t0 -> | 377 | end) |
| 389 | extra -> | 378 | in |
| 390 | Commodity_id.t -> | 379 | Inst.visit |
| 391 | Money.Diff.t -> | 380 | { |
| 392 | 'a * extra * Money.Diff.t) : 'a Structure.Mapper.t = | 381 | car = |
| 393 | { | 382 | (fun (type inner) |
| 394 | car = | 383 | v |
| 395 | (fun in_acc mkt -> | 384 | (module Gen_cons : Account_structure.Gen_f_cons.S |
| 396 | let open Option.Let_syntax in | 385 | with type inner = inner |
| 397 | match (subaid, in_acc) with | 386 | and type outer = b) |
| 398 | | [], (extra, Leaf (acc_comm, acc_bal)) -> | 387 | -> |
| 399 | let x, extra', acc_bal' = | 388 | let open Option.Let_syntax in |
| 400 | f (mkt Account_type.Leaf) extra acc_comm acc_bal | 389 | let module Type_cons = Gen_cons.Specialize (Account_type) in |
| 401 | in | 390 | let module Own_cons = Gen_cons.Specialize (Structure) in |
| 402 | Some (x, (extra', Leaf (acc_comm, acc_bal'))) | 391 | let%map c, v' = f.car v (fun el -> mkt (Type_cons.cons el)) in |
| 403 | | [], _ -> None | 392 | (c, Own_cons.cons v')); |
| 404 | | subaid0 :: subaid, (extra, Node subaccs) -> | 393 | } |
| 405 | let%bind subacc = Map.find subaccs subaid0 in | 394 | end |
| 406 | let%map x, subacc' = | 395 | |
| 407 | Structure.Mapper.map | 396 | let rec unsafe_alter_aux (subaid : Account_path.t) |
| 408 | (unsafe_alter_aux subaid f) | 397 | (f : |
| 409 | (fun k -> mkt (Node k)) | 398 | Account_type.t0 -> |
| 410 | subacc | 399 | extra -> |
| 411 | in | 400 | Commodity_id.t -> |
| 412 | (x, (extra, Node (Map.set subaccs ~key:subaid0 ~data:subacc'))) | 401 | Money.Diff.t -> |
| 413 | | subaid0 :: subaid, (extra, Ind subaccs) -> | 402 | 'a * extra * Money.Diff.t) : 'a Mapper.t = |
| 414 | let%bind subacc = Map.find subaccs subaid0 in | 403 | { |
| 415 | let%map x, subacc' = | 404 | car = |
| 416 | (unsafe_alter_aux subaid f).car subacc mkt | 405 | (fun in_acc mkt -> |
| 417 | in | ||
| 418 | (x, (extra, Ind (Map.set subaccs ~key:subaid0 ~data:subacc'))) | ||
| 419 | | _ :: _, (_, Leaf _) -> None); | ||
| 420 | } | ||
| 421 | |||
| 422 | let unsafe_alter (aid : Account_path.t) | ||
| 423 | (f : | ||
| 424 | Account_type.t0 -> | ||
| 425 | extra -> | ||
| 426 | Commodity_id.t -> | ||
| 427 | Money.Diff.t -> | ||
| 428 | 'a * extra * Money.Diff.t) (w : world) : ('a * world) option = | ||
| 429 | match aid with | ||
| 430 | | [] -> None | ||
| 431 | | aid0 :: subaid -> ( | ||
| 432 | let open Option.Let_syntax in | 406 | let open Option.Let_syntax in |
| 433 | match%bind Map.find w aid0 with | 407 | match (subaid, in_acc) with |
| 434 | | Asset acc -> | 408 | | [], (extra, Leaf (acc_comm, acc_bal)) -> |
| 435 | let%map x, acc' = | 409 | let x, extra', acc_bal' = |
| 436 | (unsafe_alter_aux subaid f).car acc (fun k -> Asset k) | 410 | f (mkt Account_type.Leaf) extra acc_comm acc_bal |
| 437 | in | ||
| 438 | (x, Map.set w ~key:aid0 ~data:(Asset acc')) | ||
| 439 | | Expense acc -> | ||
| 440 | let%map x, acc' = | ||
| 441 | (unsafe_alter_aux subaid f).car acc (fun k -> Expense k) | ||
| 442 | in | ||
| 443 | (x, Map.set w ~key:aid0 ~data:(Expense acc')) | ||
| 444 | | Income acc -> | ||
| 445 | let%map x, acc' = | ||
| 446 | (unsafe_alter_aux subaid f).car acc (fun k -> Income k) | ||
| 447 | in | 411 | in |
| 448 | (x, Map.set w ~key:aid0 ~data:(Income acc')) | 412 | Some (x, (extra', Leaf (acc_comm, acc_bal'))) |
| 449 | | Liability acc -> | 413 | | [], _ -> None |
| 450 | let%map x, acc' = | 414 | | subaid0 :: subaid, (extra, Node subaccs) -> |
| 451 | (unsafe_alter_aux subaid f).car acc (fun k -> Liability k) | 415 | let%bind subacc = Map.find subaccs subaid0 in |
| 452 | in | 416 | let%map x, subacc' = |
| 453 | (x, Map.set w ~key:aid0 ~data:(Liability acc')) | 417 | Mapper.map |
| 454 | | Equity acc -> | 418 | (unsafe_alter_aux subaid f) |
| 455 | let%map x, acc' = | 419 | (fun k -> mkt (Node k)) |
| 456 | (unsafe_alter_aux subaid f).car acc (fun k -> Equity k) | 420 | subacc |
| 457 | in | ||
| 458 | (x, Map.set w ~key:aid0 ~data:(Equity acc'))) | ||
| 459 | |||
| 460 | (** Update the balance (debit/credit ([dc])) of account [aid] [by_amount] | ||
| 461 | (commodity: [in_comm]) in [world], giving the updated world and the pre | ||
| 462 | and post balances for [aid] iff the account exists in [world]. *) | ||
| 463 | let update_bal aid dc by_amount in_comm (w : world) : | ||
| 464 | (Money.Diff.t * Money.Diff.t * world) option = | ||
| 465 | let open Option.Let_syntax in | ||
| 466 | let%bind mres, w' = | ||
| 467 | unsafe_alter aid | ||
| 468 | (fun acc_type acc_extra acc_comm acc_bal -> | ||
| 469 | if not ([%equal: Commodity_id.t] acc_comm in_comm) then | ||
| 470 | (None, acc_extra, acc_bal) | ||
| 471 | else | ||
| 472 | let on_debit = | ||
| 473 | match acc_type with | ||
| 474 | | Asset _ -> `Incr | ||
| 475 | | Expense _ -> `Incr | ||
| 476 | | Income _ -> `Decr | ||
| 477 | | Liability _ -> `Decr | ||
| 478 | | Equity _ -> `Decr | ||
| 479 | in | ||
| 480 | let acc_bal' = | ||
| 481 | Money.Diff.(acc_bal + of_amount by_amount dc ~on_debit) | ||
| 482 | in | ||
| 483 | (Some (acc_bal, acc_bal'), acc_extra, acc_bal')) | ||
| 484 | w | ||
| 485 | in | ||
| 486 | let%map pre_bal, post_bal = mres in | ||
| 487 | (pre_bal, post_bal, w') | ||
| 488 | |||
| 489 | let get_bal aid (w : world) : (Commodity_id.t * Money.Diff.t) option = | ||
| 490 | let open Option.Let_syntax in | ||
| 491 | let%map cb, _world' = | ||
| 492 | unsafe_alter aid | ||
| 493 | (fun _acc_type acc_extra acc_comm acc_bal -> | ||
| 494 | ((acc_comm, acc_bal), acc_extra, acc_bal)) | ||
| 495 | w | ||
| 496 | in | ||
| 497 | cb | ||
| 498 | |||
| 499 | let add_balance_maps m1 m2 : Money.Diff.t Commodity_id.Map.t = | ||
| 500 | Map.merge m1 m2 ~f:(fun ~key:_comm -> function | ||
| 501 | | `Both (b1, b2) -> Some Money.Diff.(b1 + b2) | ||
| 502 | | `Left b | `Right b -> Some b) | ||
| 503 | |||
| 504 | let rec collect_balances : type a. | ||
| 505 | a Structure.f account -> Money.Diff.t Commodity_id.Map.t = function | ||
| 506 | | _extra, Leaf (acc_comm, acc_bal) -> | ||
| 507 | Commodity_id.Map.singleton acc_comm acc_bal | ||
| 508 | | _extra, Ind subaccs -> | ||
| 509 | Map.fold subaccs ~init:Commodity_id.Map.empty | ||
| 510 | ~f:(fun ~key:_ ~data:subacc comm_bal_sums -> | ||
| 511 | add_balance_maps comm_bal_sums (collect_balances subacc)) | ||
| 512 | | _extra, Node subaccs -> | ||
| 513 | Map.fold subaccs ~init:Commodity_id.Map.empty | ||
| 514 | ~f:(fun ~key:_ ~data:subacc comm_bal_sums -> | ||
| 515 | let module Visitor = | ||
| 516 | Account_structure0.Basic_visitor (Scaffold) (Structure) | ||
| 517 | in | 421 | in |
| 518 | add_balance_maps comm_bal_sums | 422 | (x, (extra, Node (Map.set subaccs ~key:subaid0 ~data:subacc'))) |
| 519 | (Visitor.visit { car = collect_balances } subacc)) | 423 | | subaid0 :: subaid, (extra, Ind subaccs) -> |
| 520 | 424 | let%bind subacc = Map.find subaccs subaid0 in | |
| 521 | type delete_error = Not_found | Nonzero_balance | 425 | let%map x, subacc' = (unsafe_alter_aux subaid f).car subacc mkt in |
| 426 | (x, (extra, Ind (Map.set subaccs ~key:subaid0 ~data:subacc'))) | ||
| 427 | | _ :: _, (_, Leaf _) -> None); | ||
| 428 | } | ||
| 522 | 429 | ||
| 523 | (* | 430 | let unsafe_alter (aid : Account_path.t) |
| 431 | (f : | ||
| 432 | Account_type.t0 -> | ||
| 433 | extra -> | ||
| 434 | Commodity_id.t -> | ||
| 435 | Money.Diff.t -> | ||
| 436 | 'a * extra * Money.Diff.t) (w : world) : ('a * world) option = | ||
| 437 | match aid with | ||
| 438 | | [] -> None | ||
| 439 | | aid0 :: subaid -> ( | ||
| 440 | let open Option.Let_syntax in | ||
| 441 | match%bind Map.find w aid0 with | ||
| 442 | | Asset acc -> | ||
| 443 | let%map x, acc' = | ||
| 444 | (unsafe_alter_aux subaid f).car acc (fun k -> Asset k) | ||
| 445 | in | ||
| 446 | (x, Map.set w ~key:aid0 ~data:(Asset acc')) | ||
| 447 | | Expense acc -> | ||
| 448 | let%map x, acc' = | ||
| 449 | (unsafe_alter_aux subaid f).car acc (fun k -> Expense k) | ||
| 450 | in | ||
| 451 | (x, Map.set w ~key:aid0 ~data:(Expense acc')) | ||
| 452 | | Income acc -> | ||
| 453 | let%map x, acc' = | ||
| 454 | (unsafe_alter_aux subaid f).car acc (fun k -> Income k) | ||
| 455 | in | ||
| 456 | (x, Map.set w ~key:aid0 ~data:(Income acc')) | ||
| 457 | | Liability acc -> | ||
| 458 | let%map x, acc' = | ||
| 459 | (unsafe_alter_aux subaid f).car acc (fun k -> Liability k) | ||
| 460 | in | ||
| 461 | (x, Map.set w ~key:aid0 ~data:(Liability acc')) | ||
| 462 | | Equity acc -> | ||
| 463 | let%map x, acc' = | ||
| 464 | (unsafe_alter_aux subaid f).car acc (fun k -> Equity k) | ||
| 465 | in | ||
| 466 | (x, Map.set w ~key:aid0 ~data:(Equity acc'))) | ||
| 467 | |||
| 468 | (** Update the balance (debit/credit ([dc])) of account [aid] [by_amount] | ||
| 469 | (commodity: [in_comm]) in [world], giving the updated world and the pre | ||
| 470 | and post balances for [aid] iff the account exists in [world]. *) | ||
| 471 | let update_bal aid dc by_amount in_comm (w : world) : | ||
| 472 | (Money.Diff.t * Money.Diff.t * world) option = | ||
| 473 | let open Option.Let_syntax in | ||
| 474 | let%bind mres, w' = | ||
| 475 | unsafe_alter aid | ||
| 476 | (fun acc_type acc_extra acc_comm acc_bal -> | ||
| 477 | if not ([%equal: Commodity_id.t] acc_comm in_comm) then | ||
| 478 | (None, acc_extra, acc_bal) | ||
| 479 | else | ||
| 480 | let on_debit = | ||
| 481 | match acc_type with | ||
| 482 | | Asset _ -> `Incr | ||
| 483 | | Expense _ -> `Incr | ||
| 484 | | Income _ -> `Decr | ||
| 485 | | Liability _ -> `Decr | ||
| 486 | | Equity _ -> `Decr | ||
| 487 | in | ||
| 488 | let acc_bal' = | ||
| 489 | Money.Diff.(acc_bal + of_amount by_amount dc ~on_debit) | ||
| 490 | in | ||
| 491 | (Some (acc_bal, acc_bal'), acc_extra, acc_bal')) | ||
| 492 | w | ||
| 493 | in | ||
| 494 | let%map pre_bal, post_bal = mres in | ||
| 495 | (pre_bal, post_bal, w') | ||
| 496 | |||
| 497 | let get_bal aid (w : world) : (Commodity_id.t * Money.Diff.t) option = | ||
| 498 | let open Option.Let_syntax in | ||
| 499 | let%map cb, _world' = | ||
| 500 | unsafe_alter aid | ||
| 501 | (fun _acc_type acc_extra acc_comm acc_bal -> | ||
| 502 | ((acc_comm, acc_bal), acc_extra, acc_bal)) | ||
| 503 | w | ||
| 504 | in | ||
| 505 | cb | ||
| 506 | |||
| 507 | let add_balance_maps m1 m2 : Money.Diff.t Commodity_id.Map.t = | ||
| 508 | Map.merge m1 m2 ~f:(fun ~key:_comm -> function | ||
| 509 | | `Both (b1, b2) -> Some Money.Diff.(b1 + b2) | ||
| 510 | | `Left b | `Right b -> Some b) | ||
| 511 | |||
| 512 | let rec collect_balances : type a. | ||
| 513 | a Structure.f account -> Money.Diff.t Commodity_id.Map.t = function | ||
| 514 | | _extra, Leaf (acc_comm, acc_bal) -> | ||
| 515 | Commodity_id.Map.singleton acc_comm acc_bal | ||
| 516 | | _extra, Ind subaccs -> | ||
| 517 | Map.fold subaccs ~init:Commodity_id.Map.empty | ||
| 518 | ~f:(fun ~key:_ ~data:subacc comm_bal_sums -> | ||
| 519 | add_balance_maps comm_bal_sums (collect_balances subacc)) | ||
| 520 | | _extra, Node subaccs -> | ||
| 521 | Map.fold subaccs ~init:Commodity_id.Map.empty | ||
| 522 | ~f:(fun ~key:_ ~data:subacc comm_bal_sums -> | ||
| 523 | let module Visitor = Account_structure.Basic_visitor (Structure) in | ||
| 524 | add_balance_maps comm_bal_sums | ||
| 525 | (Visitor.visit { car = collect_balances } subacc)) | ||
| 526 | |||
| 527 | type delete_error = Not_found | Nonzero_balance | ||
| 528 | |||
| 529 | (* | ||
| 524 | let rec delete_aux : type a. (Account_path.t * a f account) -> (a f account, delete_error) result = function | 530 | let rec delete_aux : type a. (Account_path.t * a f account) -> (a f account, delete_error) result = function |
| 525 | | [], (extra, Leaf (_acc_comm, acc_bal)) -> | 531 | | [], (extra, Leaf (_acc_comm, acc_bal)) -> |
| 526 | if Money.Diff.(acc_bal = ~$0) then | 532 | if Money.Diff.(acc_bal = ~$0) then |
| @@ -528,152 +534,152 @@ module Account_structure0 = struct | |||
| 528 | let delete (aid : Account_path.t) (w : world) = | 534 | let delete (aid : Account_path.t) (w : world) = |
| 529 | *) | 535 | *) |
| 530 | 536 | ||
| 531 | let world_inst : world = | 537 | let world_inst : world = |
| 532 | String.Map.of_alist_exn | 538 | String.Map.of_alist_exn |
| 533 | [ | 539 | [ |
| 534 | ( "Assets", | 540 | ( "Assets", |
| 535 | Structure.Asset | 541 | Structure.Asset |
| 536 | ( { description = "assets" }, | 542 | ( { description = "assets" }, |
| 537 | Ind | 543 | Ind |
| 538 | (String.Map.of_alist_exn | 544 | (String.Map.of_alist_exn |
| 539 | [ | 545 | [ |
| 540 | ( "Current", | 546 | ( "Current", |
| 541 | ( { description = "current" }, | 547 | ( { description = "current" }, |
| 542 | Node | 548 | Node |
| 543 | (String.Map.of_alist_exn | 549 | (String.Map.of_alist_exn |
| 544 | [ | 550 | [ |
| 545 | ( "Checking", | 551 | ( "Checking", |
| 546 | Structure.Bank | 552 | Structure.Bank |
| 547 | ( { description = "bnak accounts" }, | 553 | ( { description = "bnak accounts" }, |
| 548 | Ind | 554 | Ind |
| 549 | (String.Map.of_alist_exn | 555 | (String.Map.of_alist_exn |
| 550 | [ | 556 | [ |
| 551 | ( "ING", | 557 | ( "ING", |
| 552 | ( { description = "ING bank" }, | 558 | ( { description = "ING bank" }, |
| 553 | Leaf ("EUC", Money.Diff.(~$0)) | 559 | Leaf ("EUC", Money.Diff.(~$0)) |
| 554 | ) ); | 560 | ) ); |
| 555 | ( "N26", | 561 | ( "N26", |
| 556 | ( { description = "ING bank" }, | 562 | ( { description = "ING bank" }, |
| 557 | Leaf ("EUC", Money.Diff.(~$0)) | 563 | Leaf ("EUC", Money.Diff.(~$0)) |
| 558 | ) ); | 564 | ) ); |
| 559 | ]) ) ); | 565 | ]) ) ); |
| 560 | ]) ) ); | 566 | ]) ) ); |
| 561 | ]) ) ); | 567 | ]) ) ); |
| 562 | ] | 568 | ] |
| 563 | end | 569 | end |
| 564 | |||
| 565 | module Bal_assert = struct | ||
| 566 | type t = { account : Account_path.t; labels : Labels.t; bal : Money.Diff.t } | ||
| 567 | [@@deriving sexp_of] | ||
| 568 | end | ||
| 569 | |||
| 570 | module Account_decl = struct | ||
| 571 | type t = { | ||
| 572 | type_ : Account_type.t0; | ||
| 573 | parent : Account_path.t; | ||
| 574 | name : string; | ||
| 575 | commodity : Commodity_id.t; | ||
| 576 | extra : Account_hierarchy.extra; | ||
| 577 | } | ||
| 578 | [@@deriving sexp_of] | ||
| 579 | end | ||
| 580 | |||
| 581 | module Tx : sig | ||
| 582 | type entry = { | ||
| 583 | dc : Debit_credit.t; | ||
| 584 | commodity : Commodity_id.t; | ||
| 585 | amount : Money.Amount.t; | ||
| 586 | assertion : Money.Diff.t option; | ||
| 587 | } | ||
| 588 | |||
| 589 | (* Private because we only want to allow constructing balanced transactions. *) | ||
| 590 | type t = private { | ||
| 591 | cleared : Date.t option; | ||
| 592 | entries : entry Account_path.Map.t; | ||
| 593 | labels : Labels.t; | ||
| 594 | } | ||
| 595 | 570 | ||
| 596 | type error = Unbalanced | 571 | module Bal_assert = struct |
| 572 | type t = { account : Account_path.t; labels : Labels.t; bal : Money.Diff.t } | ||
| 573 | [@@deriving sexp_of] | ||
| 574 | end | ||
| 597 | 575 | ||
| 598 | val make : | 576 | module Account_decl = struct |
| 599 | cleared:Date.t option -> | 577 | type t = { |
| 600 | entries:entry Account_path.Map.t -> | 578 | type_ : Account_type.t0; |
| 601 | labels:Labels.t -> | 579 | parent : Account_path.t; |
| 602 | (t, error) result | 580 | name : string; |
| 581 | commodity : Commodity_id.t; | ||
| 582 | extra : Account_hierarchy.extra; | ||
| 583 | } | ||
| 584 | [@@deriving sexp_of] | ||
| 585 | end | ||
| 603 | 586 | ||
| 604 | val sexp_of_t : t -> Sexp.t | 587 | module Tx : sig |
| 605 | end = struct | 588 | type entry = { |
| 606 | type entry = { | 589 | dc : Debit_credit.t; |
| 607 | dc : Debit_credit.t; | 590 | commodity : Commodity_id.t; |
| 608 | commodity : Commodity_id.t; | 591 | amount : Money.Amount.t; |
| 609 | amount : Money.Amount.t; | 592 | assertion : Money.Diff.t option; |
| 610 | assertion : Money.Diff.t option; | 593 | } |
| 611 | } | 594 | |
| 612 | [@@deriving sexp_of] | 595 | (* Private because we only want to allow constructing balanced transactions. *) |
| 596 | type t = private { | ||
| 597 | cleared : Date.t option; | ||
| 598 | entries : entry Account_path.Map.t; | ||
| 599 | labels : Labels.t; | ||
| 600 | } | ||
| 601 | |||
| 602 | type error = Unbalanced | ||
| 603 | |||
| 604 | val make : | ||
| 605 | cleared:Date.t option -> | ||
| 606 | entries:entry Account_path.Map.t -> | ||
| 607 | labels:Labels.t -> | ||
| 608 | (t, error) result | ||
| 609 | |||
| 610 | val sexp_of_t : t -> Sexp.t | ||
| 611 | end = struct | ||
| 612 | type entry = { | ||
| 613 | dc : Debit_credit.t; | ||
| 614 | commodity : Commodity_id.t; | ||
| 615 | amount : Money.Amount.t; | ||
| 616 | assertion : Money.Diff.t option; | ||
| 617 | } | ||
| 618 | [@@deriving sexp_of] | ||
| 613 | 619 | ||
| 614 | type t = { | 620 | type t = { |
| 615 | cleared : Date.t option; | 621 | cleared : Date.t option; |
| 616 | entries : entry Account_path.Map.t; | 622 | entries : entry Account_path.Map.t; |
| 617 | labels : Labels.t; | 623 | labels : Labels.t; |
| 618 | } | 624 | } |
| 619 | [@@deriving sexp_of] | 625 | [@@deriving sexp_of] |
| 620 | 626 | ||
| 621 | type error = Unbalanced | 627 | type error = Unbalanced |
| 622 | 628 | ||
| 623 | let is_balanced entries = | 629 | let is_balanced entries = |
| 624 | Map.fold entries ~init:Commodity_id.Map.empty | 630 | Map.fold entries ~init:Commodity_id.Map.empty |
| 625 | ~f:(fun ~key:_ ~data comm_balances -> | 631 | ~f:(fun ~key:_ ~data comm_balances -> |
| 626 | Map.update comm_balances data.commodity ~f:(fun ocomm_bal -> | 632 | Map.update comm_balances data.commodity ~f:(fun ocomm_bal -> |
| 627 | let comm_bal = Option.value ocomm_bal ~default:Money.Diff.(~$0) in | 633 | let comm_bal = Option.value ocomm_bal ~default:Money.Diff.(~$0) in |
| 628 | match data.dc with | 634 | match data.dc with |
| 629 | | Debit_credit.Debit -> Money.Diff.(comm_bal +% data.amount) | 635 | | Debit_credit.Debit -> Money.Diff.(comm_bal +% data.amount) |
| 630 | | Debit_credit.Credit -> Money.Diff.(comm_bal -% data.amount))) | 636 | | Debit_credit.Credit -> Money.Diff.(comm_bal -% data.amount))) |
| 631 | |> Map.for_all ~f:(fun comm_bal -> Money.Diff.(comm_bal = ~$0)) | 637 | |> Map.for_all ~f:(fun comm_bal -> Money.Diff.(comm_bal = ~$0)) |
| 632 | 638 | ||
| 633 | let make ~cleared ~entries ~labels = | 639 | let make ~cleared ~entries ~labels = |
| 634 | if not (is_balanced entries) then Error Unbalanced | 640 | if not (is_balanced entries) then Error Unbalanced |
| 635 | else Ok { cleared; entries; labels } | 641 | else Ok { cleared; entries; labels } |
| 636 | end | 642 | end |
| 637 | 643 | ||
| 638 | type item = | 644 | type item = |
| 639 | | Tx_item of Tx.t | 645 | | Tx_item of Tx.t |
| 640 | | Bal_assert_item of Bal_assert.t | 646 | | Bal_assert_item of Bal_assert.t |
| 641 | | Account_decl_item of Account_decl.t | 647 | | Account_decl_item of Account_decl.t |
| 642 | [@@deriving sexp_of] | 648 | [@@deriving sexp_of] |
| 643 | 649 | ||
| 644 | type t = item list [@@deriving sexp_of] | 650 | type t = item list [@@deriving sexp_of] |
| 645 | 651 | ||
| 646 | module World = struct | 652 | module World = struct |
| 647 | type t = Account_hierarchy.world | 653 | type t = Account_hierarchy.world |
| 648 | 654 | ||
| 649 | let empty : t = String.Map.empty | 655 | let empty : t = String.Map.empty |
| 650 | 656 | ||
| 651 | let apply_tx (tx : Tx.t) world : t option = | 657 | let apply_tx (tx : Tx.t) world : t option = |
| 652 | Map.fold_option tx.entries ~init:world | 658 | Map.fold_option tx.entries ~init:world |
| 653 | ~f:(fun ~key:aid ~(data : Tx.entry) world -> | 659 | ~f:(fun ~key:aid ~(data : Tx.entry) world -> |
| 654 | let open Option.Let_syntax in | 660 | let open Option.Let_syntax in |
| 655 | let%bind _old_bal, new_bal, world = | 661 | let%bind _old_bal, new_bal, world = |
| 656 | Account_hierarchy.update_bal aid data.dc data.amount data.commodity | 662 | Account_hierarchy.update_bal aid data.dc data.amount data.commodity |
| 657 | world | 663 | world |
| 658 | in | 664 | in |
| 659 | match data.assertion with | 665 | match data.assertion with |
| 660 | | None -> Some world | 666 | | None -> Some world |
| 661 | | Some bal_ass -> | 667 | | Some bal_ass -> |
| 662 | if Money.Diff.(bal_ass = new_bal) then Some world else None) | 668 | if Money.Diff.(bal_ass = new_bal) then Some world else None) |
| 663 | 669 | ||
| 664 | let apply_ba (ba : Bal_assert.t) world : t option = | 670 | let apply_ba (ba : Bal_assert.t) world : t option = |
| 665 | let open Option.Let_syntax in | 671 | let open Option.Let_syntax in |
| 666 | let%bind _comm, bal = Account_hierarchy.get_bal ba.account world in | 672 | let%bind _comm, bal = Account_hierarchy.get_bal ba.account world in |
| 667 | if not Money.Diff.(bal = ba.bal) then None else Some world | 673 | if not Money.Diff.(bal = ba.bal) then None else Some world |
| 668 | 674 | ||
| 669 | let apply_ad (_ad : Account_decl.t) _world : t option = None | 675 | let apply_ad (_ad : Account_decl.t) _world : t option = None |
| 670 | 676 | ||
| 671 | let apply : item -> t -> t option = function | 677 | let apply : item -> t -> t option = function |
| 672 | | Tx_item tx -> apply_tx tx | 678 | | Tx_item tx -> apply_tx tx |
| 673 | | Bal_assert_item ba -> apply_ba ba | 679 | | Bal_assert_item ba -> apply_ba ba |
| 674 | | Account_decl_item ad -> apply_ad ad | 680 | | Account_decl_item ad -> apply_ad ad |
| 675 | end | 681 | end |
| 676 | 682 | ||
| 677 | module Ctxd_item = struct end | 683 | module Ctxd_item = struct end |
| 678 | 684 | ||
| 679 | let make = Fn.id | 685 | let make = Fn.id |