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