summaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
authorRutger Broekhoff2026-01-09 16:36:01 +0100
committerRutger Broekhoff2026-01-09 16:36:01 +0100
commit2367d2caa83831992392069c21bd96cb91e113f0 (patch)
tree518c3e05529fce24b82287d90cf68bc32dd04c7e /lib
parentd6c9993c2eb51650d44507ec601151cba4159039 (diff)
downloadrdcapsis-2367d2caa83831992392069c21bd96cb91e113f0.tar.gz
rdcapsis-2367d2caa83831992392069c21bd96cb91e113f0.zip
BYE BYE
Diffstat (limited to 'lib')
-rw-r--r--lib/ledger.ml732
1 files changed, 369 insertions, 363 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
185module Account_structure0 = struct 185module 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 313end
294
295 module Account_type = struct
296 type 'a elem = Leaf | Node of 'a [@@deriving sexp_of]
297
298 module Scaffold = struct
299 type 'a t = 'a elem [@@deriving sexp_of]
300 end
301
302 include Account_structure0.Make (Scaffold)
303 end
304
305 module Account_structure (F : Account_structure0.Scaffold) = struct
306 module Structure = Account_structure0.Make (F)
307 include Structure
308 314
309 module Mapper = struct 315module Account_type = struct
310 type nonrec 'b t = { 316 type 'a elem = Leaf | Node of 'a [@@deriving sexp_of]
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 317
318 let map (type b c) (f : c t) (mkt : b Account_type.f -> Account_type.t0) : 318 include Account_structure.Make (struct
319 b f -> (c * b f) option = 319 type 'a t = 'a elem [@@deriving sexp_of]
320 let module Inst = 320 end)
321 Account_structure0.Visitor (F) (Structure) 321end
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 322
346 module Typed_account_path = struct 323module Typed_account_path = struct
347 type 'a elem = Leaf | Node of string * 'a | Ind of string * 'a elem 324 type 'a elem = Leaf | Node of string * 'a | Ind of string * 'a elem
348 [@@deriving sexp_of] 325 [@@deriving sexp_of]
349 326
350 include Account_structure (struct 327 include Account_structure.Make (struct
351 type 'a t = 'a elem [@@deriving sexp_of] 328 type 'a t = 'a elem [@@deriving sexp_of]
352 end) 329 end)
353 end 330end
354 331
355 module Account_path = struct 332module Account_path = struct
356 type t = string list [@@deriving compare, sexp] 333 type t = string list [@@deriving compare, sexp]
357 334
358 module Map = Map.Make (struct 335 module Map = Map.Make (struct
359 type nonrec t = t [@@deriving compare, sexp] 336 type nonrec t = t [@@deriving compare, sexp]
360 end) 337 end)
361 end 338end
362 339
363 module Account_hierarchy = struct 340module Account_hierarchy = struct
364 (* The contents of an account of category 'a *) 341 (* The contents of an account of category 'a *)
365 type 'a core = 342 type 'a core =
366 (* Comprises of subaccounts of its subcategories *) 343 (* Comprises of subaccounts of its subcategories *)
367 | Node of 'a String.Map.t 344 | Node of 'a String.Map.t
368 (* Comprises of subaccounts of its own category *) 345 (* Comprises of subaccounts of its own category *)
369 | Ind of 'a account String.Map.t 346 | Ind of 'a account String.Map.t
370 (* Has no subaccounts, has a balance in a certain commodity *) 347 (* Has no subaccounts, has a balance in a certain commodity *)
371 | Leaf of Commodity_id.t * Money.Diff.t 348 | Leaf of Commodity_id.t * Money.Diff.t
372 [@@deriving sexp_of] 349 [@@deriving sexp_of]
373 350
374 and extra = { description : String.t } [@@deriving sexp_of] 351 and extra = { description : String.t } [@@deriving sexp_of]
375 and 'a account = extra * 'a core 352 and 'a account = extra * 'a core
376 353
377 module Scaffold = struct 354 module Structure = Account_structure.Make (struct
378 type 'a t = 'a account [@@deriving sexp_of] 355 type 'a t = 'a account [@@deriving sexp_of]
379 end 356 end)
380 357
381 module Structure = Account_structure (Scaffold) 358 (* All accounts *)
359 type world = Structure.t0 String.Map.t
382 360
383 (* All accounts *) 361 module Mapper = struct
384 type world = Structure.t0 String.Map.t 362 type nonrec 'b t = {
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 }
385 369
386 let rec unsafe_alter_aux (subaid : Account_path.t) 370 let map (type b c) (f : c t) (mkt : b Account_type.f -> Account_type.t0) :
387 (f : 371 b Structure.f -> (c * b Structure.f) option =
388 Account_type.t0 -> 372 let module Inst =
389 extra -> 373 Account_structure.Visitor
390 Commodity_id.t -> 374 (Structure)
391 Money.Diff.t -> 375 (struct
392 'a * extra * Money.Diff.t) : 'a Structure.Mapper.t = 376 type 'b t = (c * 'b Structure.f) option
393 { 377 end)
394 car = 378 in
395 (fun in_acc mkt -> 379 Inst.visit
396 let open Option.Let_syntax in 380 {
397 match (subaid, in_acc) with 381 car =
398 | [], (extra, Leaf (acc_comm, acc_bal)) -> 382 (fun (type inner)
399 let x, extra', acc_bal' = 383 v
400 f (mkt Account_type.Leaf) extra acc_comm acc_bal 384 (module Gen_cons : Account_structure.Gen_f_cons.S
401 in 385 with type inner = inner
402 Some (x, (extra', Leaf (acc_comm, acc_bal'))) 386 and type outer = b)
403 | [], _ -> None 387 ->
404 | subaid0 :: subaid, (extra, Node subaccs) -> 388 let open Option.Let_syntax in
405 let%bind subacc = Map.find subaccs subaid0 in 389 let module Type_cons = Gen_cons.Specialize (Account_type) in
406 let%map x, subacc' = 390 let module Own_cons = Gen_cons.Specialize (Structure) in
407 Structure.Mapper.map 391 let%map c, v' = f.car v (fun el -> mkt (Type_cons.cons el)) in
408 (unsafe_alter_aux subaid f) 392 (c, Own_cons.cons v'));
409 (fun k -> mkt (Node k)) 393 }
410 subacc 394 end
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 395
422 let unsafe_alter (aid : Account_path.t) 396 let rec unsafe_alter_aux (subaid : Account_path.t)
423 (f : 397 (f :
424 Account_type.t0 -> 398 Account_type.t0 ->
425 extra -> 399 extra ->
426 Commodity_id.t -> 400 Commodity_id.t ->
427 Money.Diff.t -> 401 Money.Diff.t ->
428 'a * extra * Money.Diff.t) (w : world) : ('a * world) option = 402 'a * extra * Money.Diff.t) : 'a Mapper.t =
429 match aid with 403 {
430 | [] -> None 404 car =
431 | aid0 :: subaid -> ( 405 (fun in_acc mkt ->
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 411 in
443 (x, Map.set w ~key:aid0 ~data:(Expense acc')) 412 Some (x, (extra', Leaf (acc_comm, acc_bal')))
444 | Income acc -> 413 | [], _ -> None
445 let%map x, acc' = 414 | subaid0 :: subaid, (extra, Node subaccs) ->
446 (unsafe_alter_aux subaid f).car acc (fun k -> Income k) 415 let%bind subacc = Map.find subaccs subaid0 in
416 let%map x, subacc' =
417 Mapper.map
418 (unsafe_alter_aux subaid f)
419 (fun k -> mkt (Node k))
420 subacc
447 in 421 in
448 (x, Map.set w ~key:aid0 ~data:(Income acc')) 422 (x, (extra, Node (Map.set subaccs ~key:subaid0 ~data:subacc')))
449 | Liability acc -> 423 | subaid0 :: subaid, (extra, Ind subaccs) ->
450 let%map x, acc' = 424 let%bind subacc = Map.find subaccs subaid0 in
451 (unsafe_alter_aux subaid f).car acc (fun k -> Liability k) 425 let%map x, subacc' = (unsafe_alter_aux subaid f).car subacc mkt in
452 in 426 (x, (extra, Ind (Map.set subaccs ~key:subaid0 ~data:subacc')))
453 (x, Map.set w ~key:aid0 ~data:(Liability acc')) 427 | _ :: _, (_, Leaf _) -> None);
454 | Equity acc -> 428 }
455 let%map x, acc' =
456 (unsafe_alter_aux subaid f).car acc (fun k -> Equity k)
457 in
458 (x, Map.set w ~key:aid0 ~data:(Equity acc')))
459 429
460 (** Update the balance (debit/credit ([dc])) of account [aid] [by_amount] 430 let unsafe_alter (aid : Account_path.t)
461 (commodity: [in_comm]) in [world], giving the updated world and the pre 431 (f :
462 and post balances for [aid] iff the account exists in [world]. *) 432 Account_type.t0 ->
463 let update_bal aid dc by_amount in_comm (w : world) : 433 extra ->
464 (Money.Diff.t * Money.Diff.t * world) option = 434 Commodity_id.t ->
465 let open Option.Let_syntax in 435 Money.Diff.t ->
466 let%bind mres, w' = 436 'a * extra * Money.Diff.t) (w : world) : ('a * world) option =
467 unsafe_alter aid 437 match aid with
468 (fun acc_type acc_extra acc_comm acc_bal -> 438 | [] -> None
469 if not ([%equal: Commodity_id.t] acc_comm in_comm) then 439 | aid0 :: subaid -> (
470 (None, acc_extra, acc_bal) 440 let open Option.Let_syntax in
471 else 441 match%bind Map.find w aid0 with
472 let on_debit = 442 | Asset acc ->
473 match acc_type with 443 let%map x, acc' =
474 | Asset _ -> `Incr 444 (unsafe_alter_aux subaid f).car acc (fun k -> Asset k)
475 | Expense _ -> `Incr 445 in
476 | Income _ -> `Decr 446 (x, Map.set w ~key:aid0 ~data:(Asset acc'))
477 | Liability _ -> `Decr 447 | Expense acc ->
478 | Equity _ -> `Decr 448 let%map x, acc' =
479 in 449 (unsafe_alter_aux subaid f).car acc (fun k -> Expense k)
480 let acc_bal' = 450 in
481 Money.Diff.(acc_bal + of_amount by_amount dc ~on_debit) 451 (x, Map.set w ~key:aid0 ~data:(Expense acc'))
482 in 452 | Income acc ->
483 (Some (acc_bal, acc_bal'), acc_extra, acc_bal')) 453 let%map x, acc' =
484 w 454 (unsafe_alter_aux subaid f).car acc (fun k -> Income k)
485 in 455 in
486 let%map pre_bal, post_bal = mres in 456 (x, Map.set w ~key:aid0 ~data:(Income acc'))
487 (pre_bal, post_bal, w') 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')))
488 467
489 let get_bal aid (w : world) : (Commodity_id.t * Money.Diff.t) option = 468 (** Update the balance (debit/credit ([dc])) of account [aid] [by_amount]
490 let open Option.Let_syntax in 469 (commodity: [in_comm]) in [world], giving the updated world and the pre
491 let%map cb, _world' = 470 and post balances for [aid] iff the account exists in [world]. *)
492 unsafe_alter aid 471 let update_bal aid dc by_amount in_comm (w : world) :
493 (fun _acc_type acc_extra acc_comm acc_bal -> 472 (Money.Diff.t * Money.Diff.t * world) option =
494 ((acc_comm, acc_bal), acc_extra, acc_bal)) 473 let open Option.Let_syntax in
495 w 474 let%bind mres, w' =
496 in 475 unsafe_alter aid
497 cb 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')
498 496
499 let add_balance_maps m1 m2 : Money.Diff.t Commodity_id.Map.t = 497 let get_bal aid (w : world) : (Commodity_id.t * Money.Diff.t) option =
500 Map.merge m1 m2 ~f:(fun ~key:_comm -> function 498 let open Option.Let_syntax in
501 | `Both (b1, b2) -> Some Money.Diff.(b1 + b2) 499 let%map cb, _world' =
502 | `Left b | `Right b -> Some b) 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
503 506
504 let rec collect_balances : type a. 507 let add_balance_maps m1 m2 : Money.Diff.t Commodity_id.Map.t =
505 a Structure.f account -> Money.Diff.t Commodity_id.Map.t = function 508 Map.merge m1 m2 ~f:(fun ~key:_comm -> function
506 | _extra, Leaf (acc_comm, acc_bal) -> 509 | `Both (b1, b2) -> Some Money.Diff.(b1 + b2)
507 Commodity_id.Map.singleton acc_comm acc_bal 510 | `Left b | `Right b -> Some b)
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
518 add_balance_maps comm_bal_sums
519 (Visitor.visit { car = collect_balances } subacc))
520 511
521 type delete_error = Not_found | Nonzero_balance 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))
522 526
523 (* 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 569end
564 570
565 module Bal_assert = struct 571module Bal_assert = struct
566 type t = { account : Account_path.t; labels : Labels.t; bal : Money.Diff.t } 572 type t = { account : Account_path.t; labels : Labels.t; bal : Money.Diff.t }
567 [@@deriving sexp_of] 573 [@@deriving sexp_of]
568 end 574end
569 575
570 module Account_decl = struct 576module Account_decl = struct
571 type t = { 577 type t = {
572 type_ : Account_type.t0; 578 type_ : Account_type.t0;
573 parent : Account_path.t; 579 parent : Account_path.t;
574 name : string; 580 name : string;
575 commodity : Commodity_id.t; 581 commodity : Commodity_id.t;
576 extra : Account_hierarchy.extra; 582 extra : Account_hierarchy.extra;
577 } 583 }
578 [@@deriving sexp_of] 584 [@@deriving sexp_of]
579 end 585end
580 586
581 module Tx : sig 587module Tx : sig
582 type entry = { 588 type entry = {
583 dc : Debit_credit.t; 589 dc : Debit_credit.t;
584 commodity : Commodity_id.t; 590 commodity : Commodity_id.t;
585 amount : Money.Amount.t; 591 amount : Money.Amount.t;
586 assertion : Money.Diff.t option; 592 assertion : Money.Diff.t option;
587 } 593 }
588 594
589 (* Private because we only want to allow constructing balanced transactions. *) 595 (* Private because we only want to allow constructing balanced transactions. *)
590 type t = private { 596 type t = private {
591 cleared : Date.t option; 597 cleared : Date.t option;
592 entries : entry Account_path.Map.t; 598 entries : entry Account_path.Map.t;
593 labels : Labels.t; 599 labels : Labels.t;
594 } 600 }
595 601
596 type error = Unbalanced 602 type error = Unbalanced
597 603
598 val make : 604 val make :
599 cleared:Date.t option -> 605 cleared:Date.t option ->
600 entries:entry Account_path.Map.t -> 606 entries:entry Account_path.Map.t ->
601 labels:Labels.t -> 607 labels:Labels.t ->
602 (t, error) result 608 (t, error) result
603 609
604 val sexp_of_t : t -> Sexp.t 610 val sexp_of_t : t -> Sexp.t
605 end = struct 611end = struct
606 type entry = { 612 type entry = {
607 dc : Debit_credit.t; 613 dc : Debit_credit.t;
608 commodity : Commodity_id.t; 614 commodity : Commodity_id.t;
609 amount : Money.Amount.t; 615 amount : Money.Amount.t;
610 assertion : Money.Diff.t option; 616 assertion : Money.Diff.t option;
611 } 617 }
612 [@@deriving sexp_of] 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 642end
637 643
638 type item = 644type 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] 650type t = item list [@@deriving sexp_of]
645 651
646 module World = struct 652module 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 681end
676 682
677 module Ctxd_item = struct end 683module Ctxd_item = struct end
678 684
679 let make = Fn.id 685let make = Fn.id