From c90ff5253efd858a2bf0c20eaa2ee9763a402783 Mon Sep 17 00:00:00 2001 From: Rutger Broekhoff Date: Mon, 9 Mar 2026 22:29:18 +0100 Subject: oha! --- lib/account.ml | 210 ----------------------------------------- lib/account/account.ml | 121 ++++++++++++++++++++++++ lib/account/type.ml | 15 +++ lib/account/type_hierarchy.ml | 83 ++++++++++++++++ lib/account/type_hierarchy.mli | 15 +++ lib/balanced_batch.ml | 42 +++++++++ lib/dune | 2 + lib/money.ml | 79 ++++++++++++++++ 8 files changed, 357 insertions(+), 210 deletions(-) delete mode 100644 lib/account.ml create mode 100644 lib/account/account.ml create mode 100644 lib/account/type.ml create mode 100644 lib/account/type_hierarchy.ml create mode 100644 lib/account/type_hierarchy.mli create mode 100644 lib/balanced_batch.ml create mode 100644 lib/money.ml diff --git a/lib/account.ml b/lib/account.ml deleted file mode 100644 index 3a1aff0..0000000 --- a/lib/account.ml +++ /dev/null @@ -1,210 +0,0 @@ -open Prelude - -(** The 'kernel' of account types: a hierarchy of valid types. A valid type is a - path that leads to a node in the hierarchy. *) -module Type_hierarchy : sig - type path - type polarity = Increase_on_debit | Increase_on_credit - - val children : path -> path list - val sub : path -> string -> path option - val super : path -> path option - val equal_path : path -> path -> bool - val is_prefix : path -> prefix:path -> bool - val polarity : path -> polarity - val asset : path - val equity : path - val expense : path - val income : path - val liability : path -end = struct - type polarity = Increase_on_debit | Increase_on_credit - type tree = { car : tree String.Map.t } - type trunk = { car : (polarity * tree) String.Map.t } - type path = Base of string | Sub of string * path - - let rec path_to_list ?(suffix = []) p = - match p with - | Base x -> x :: suffix - | Sub (x, p') -> path_to_list ~suffix:(x :: suffix) p' - - let canonical : trunk = - let mk alist : tree = { car = String.Map.of_alist_exn alist } in - { - car = - String.Map.of_alist_exn - [ - ( "Asset", - ( Increase_on_debit, - mk - [ - ("Accounts_receivable", mk []); - ("Bank", mk [ ("Savings", mk []); ("Checking", mk []) ]); - ("Cash", mk []); - ("Mutual_fund", mk []); - ("Stock", mk []); - ] ) ); - ("Equity", (Increase_on_credit, mk [])); - ("Expense", (Increase_on_debit, mk [])); - ("Income", (Increase_on_credit, mk [])); - ( "Liability", - ( Increase_on_credit, - mk [ ("Accounts_payable", mk []); ("Credit", mk []) ] ) ); - ]; - } - - (* In this module, only the following two function entertains the - option that the given path may not be valid (i.e., it does not - throw an exception for invalid paths). *) - let rec get_node : path -> tree option = - let open Option.Let_syntax in - function - | Base x -> - let%map _, t = Map.find canonical.car x in - t - | Sub (t, p) -> - let%bind super = get_node p in - Map.find super.car t - - (** Always gives [Some] under valid paths, giving a list of valid paths *) - let children (p : path) : path list = - let node = Option.value_exn (get_node p) in - List.map (Map.keys node.car) ~f:(fun sub -> Sub (sub, p)) - - let sub (p : path) (name : string) : path option = - let node = Option.value_exn (get_node p) in - if Map.mem node.car name then Some (Sub (name, p)) else None - - let super : path -> path option = function - | Base _ -> None - | Sub (_, super) -> Some super - - let rec equal_path p1 p2 = - match (p1, p2) with - | Base x1, Base x2 -> String.(x1 = x2) - | Sub (x1, p1'), Sub (x2, p2') -> String.(x1 = x2) && equal_path p1' p2' - | _, _ -> false - - let is_prefix (p : path) ~(prefix : path) : bool = - List.is_prefix (path_to_list p) ~prefix:(path_to_list prefix) - ~equal:String.equal - - let rec polarity = function - | Base x -> - let pol, _ = Map.find_exn canonical.car x in - pol - | Sub (_, p') -> polarity p' - - let assert_valid acc = - match get_node acc with None -> failwith "invalid base account" | _ -> acc - - let asset = Base "Asset" |> assert_valid - let equity = Base "Equity" |> assert_valid - let expense = Base "Expense" |> assert_valid - let income = Base "Income" |> assert_valid - let liability = Base "Liability" |> assert_valid -end - -module Type = struct - type t = Type_hierarchy.path [@@deriving equal] - - let rec base (t : t) : t option = - match Type_hierarchy.super t with - | None -> (* [t] is the root type *) None - | Some t' -> - (* [t] is a base type if its supertype is the root type *) - Some (Option.value (base t') ~default:t) - - (** [a] is a strict supertype of [b] *) - let is_strict_super a b = - Type_hierarchy.is_prefix b ~prefix:a && not ([%equal: t] a b) -end - -module Debit_credit = struct - type t = Debit | Credit [@@deriving string, sexp_of] - - (* let opposite = function Debit -> Credit | Credit -> Debit *) -end - -module Money = struct - module Amount : sig - type t - - val equal : t -> t -> bool - val compare : t -> t -> int - val of_bigint : Bigint.t -> t option - val to_bigint : t -> Bigint.t - val ( + ) : t -> t -> t - val ( = ) : t -> t -> bool - val sexp_of_t : t -> Sexp.t - val zero : t - end = struct - type t = Bigint.t [@@deriving sexp_of] - - let equal = Bigint.equal - let compare = Bigint.compare - let of_bigint x = if Bigint.(zero <= x) then Some x else None - let to_bigint x = x - let ( + ) x y = Bigint.(x + y) - let ( = ) = equal - let zero = Bigint.zero - end - - module Diff : sig - type t - - val equal : t -> t -> bool - val compare : t -> t -> int - val of_bigint : Bigint.t -> t - val to_bigint : t -> Bigint.t - val ( + ) : t -> t -> t - val ( +% ) : t -> Amount.t -> t - val ( - ) : t -> t -> t - val ( -% ) : t -> Amount.t -> t - val ( = ) : t -> t -> bool - val neg : t -> t - val ( ~$ ) : int -> t - val sexp_of_t : t -> Sexp.t - - val of_amount : - Amount.t -> Debit_credit.t -> on_debit:[ `Incr | `Decr ] -> t - end = struct - type t = Bigint.t [@@deriving sexp_of] - - let equal = Bigint.equal - let compare = Bigint.compare - let of_bigint x = x - let to_bigint x = x - let ( + ) x y = Bigint.(x + y) - let ( +% ) x y = x + of_bigint (Amount.to_bigint y) - let ( - ) x y = Bigint.(x - y) - let ( -% ) x y = x - of_bigint (Amount.to_bigint y) - let ( = ) = equal - let neg = Bigint.neg - let ( ~$ ) = Fn.compose of_bigint Bigint.of_int - - let of_amount x (dc : Debit_credit.t) ~on_debit = - match (dc, on_debit) with - | Debit, `Incr -> of_bigint (Amount.to_bigint x) - | Credit, `Incr -> neg (of_bigint (Amount.to_bigint x)) - | Debit, `Decr -> neg (of_bigint (Amount.to_bigint x)) - | Credit, `Decr -> of_bigint (Amount.to_bigint x) - end -end - -module Commodity_id = struct - type t = string [@@deriving equal, compare, sexp] - - module Map = Map.Make (struct - type nonrec t = t [@@deriving equal, compare, sexp] - end) -end - -module Account = struct - type t = Type.t * node - - and node = - (* Balance in some commodity *) - | Leaf of Commodity_id.t * Money.Diff.t - | Subtree of node String.Map.t -end diff --git a/lib/account/account.ml b/lib/account/account.ml new file mode 100644 index 0000000..0ef3d28 --- /dev/null +++ b/lib/account/account.ml @@ -0,0 +1,121 @@ +open Prelude + +(* TODO: Decide on public interface. Probably should not include + functions such as [unsafe_update_bal], but having [Balanced_batch] + under [Account] also feels a bit awkward. *) + +module Path = struct + type t = string list [@@deriving compare, sexp] +end + +(** Ensures that only accounts with valid type hierarchies can be constructed. +*) +module Kernel : sig + type extra = { description : string } + + type t = private { type_ : Type.t; extra : extra; core : core } + + and core = + (* Balance in some commodity *) + | Leaf of Money.Commodity_id.t * Money.Diff.t + | Subtree of t String.Map.t + + val make : Type.t -> extra -> core -> t option +end = struct + type extra = { description : string } + + type t = { type_ : Type.t; extra : extra; core : core } + + and core = + (* Balance in some commodity *) + | Leaf of Money.Commodity_id.t * Money.Diff.t + | Subtree of t String.Map.t + + let make type_ extra : core -> t option = function + | Leaf (comm, bal) -> Some { type_; extra; core = Leaf (comm, bal) } + | Subtree children -> + if + Map.for_all children ~f:(fun subacc -> + Type.is_super subacc.type_ ~super:type_ ~strict:false) + then Some { type_; extra; core = Subtree children } + else None +end + +type t = Kernel.t + +type update_bal_error = + | Empty_path + | Unmatching_commodity_id of { in_account : Money.Commodity_id.t } + | Not_a_leaf_account + | Not_a_subtree_account + | Not_found (* TODO: report at which level *) + +(* We do not necessarily expect [aid] to be a valid path, as we + always do for paths in the type hierarchy. The difference is that + the type hierarchy is fixed, while the account hierarchy can + change over the course of a year. *) +let rec unsafe_update_bal_aux (aid : Path.t) (dc : Money.Debit_credit.t) + (by_amount : Money.Amount.t) (in_comm : Money.Commodity_id.t) (w : t) : + (t, update_bal_error) result = + match (aid, w.core) with + | [], Leaf (comm, bal) -> + if [%equal: Money.Commodity_id.t] in_comm comm then (* slay! *) + let core' = + Kernel.Leaf + ( comm, + Money.Diff.(bal + of_amount by_amount dc (Type.polarity w.type_)) + ) + in + Ok (Option.value_exn (Kernel.make w.type_ w.extra core')) + else (* bruh *) + Error (Unmatching_commodity_id { in_account = comm }) + | [], Subtree _ -> Error Not_a_leaf_account + | _ :: _, Leaf _ -> Error Not_a_subtree_account + | aid0 :: aid', Subtree subaccs -> ( + match Map.find subaccs aid0 with + | None -> Error Not_found + | Some subacc -> + let open Result.Let_syntax in + let%bind subacc' = + (* TODO: when reporting at which level Not_found fails, + we want to make sure that we extend the information + in the error with the current aid0 (so we recover a + full path to where the account is missing *) + unsafe_update_bal_aux aid' dc by_amount in_comm subacc + in + let core' = + Kernel.Subtree (Map.set subaccs ~key:aid0 ~data:subacc') + in + Ok (Option.value_exn (Kernel.make w.type_ w.extra core'))) + +(* Unfortunate but true, there has to be some kind of a root account + with no type :) *) +type root = t String.Map.t + +let unsafe_update_bal (aid : Path.t) (dc : Money.Debit_credit.t) + (by_amount : Money.Amount.t) (in_comm : Money.Commodity_id.t) (w : root) : + (root, update_bal_error) result = + match aid with + | [] -> Error Empty_path + | aid0 :: aid' -> ( + match Map.find w aid0 with + | None -> Error Not_found + | Some subacc -> + let open Result.Let_syntax in + (* TODO: when reporting at which level Not_found fails, + we want to make sure that we extend the information + in the error with the current aid0 (so we recover a + full path to where the account is missing *) + let%bind subacc' = + unsafe_update_bal_aux aid' dc by_amount in_comm subacc + in + Ok (Map.set w ~key:aid0 ~data:subacc')) + +module Balanced_batch_acc_paths = Balanced_batch.Make (Path) + +let apply_balanced_batch (b : Balanced_batch_acc_paths.t) (w : root) = + Map.fold_result (Balanced_batch_acc_paths.entries b) ~init:w + ~f:(fun ~key:aid ~(data : Balanced_batch_acc_paths.entry) w -> + let open Result.Let_syntax in + let%bind w = unsafe_update_bal aid data.dc data.amount data.commodity w in + Ok w) diff --git a/lib/account/type.ml b/lib/account/type.ml new file mode 100644 index 0000000..ad7a46e --- /dev/null +++ b/lib/account/type.ml @@ -0,0 +1,15 @@ +type t = Type_hierarchy.path [@@deriving equal] + +let rec base (t : t) : t = + match Type_hierarchy.super t with + | None -> (* [t] is a base type *) t + | Some t' -> base t' + +(** [a] is a (strict) supertype of [b] *) +let is_super t ~super ~strict = + Type_hierarchy.is_prefix super ~prefix:t + && + (* strict → t ≠ super *) + ((not strict) || not ([%equal: t] t super)) + +let polarity = Type_hierarchy.polarity diff --git a/lib/account/type_hierarchy.ml b/lib/account/type_hierarchy.ml new file mode 100644 index 0000000..7f27830 --- /dev/null +++ b/lib/account/type_hierarchy.ml @@ -0,0 +1,83 @@ +open Prelude + +type tree = { car : tree String.Map.t } +type trunk = (Money.polarity * tree) String.Map.t +type path = Base of string | Sub of string * path + +let rec path_to_list ?(suffix = []) p = + match p with + | Base x -> x :: suffix + | Sub (x, p') -> path_to_list ~suffix:(x :: suffix) p' + +let canonical : trunk = + let make alist : tree = { car = String.Map.of_alist_exn alist } in + String.Map.of_alist_exn + [ + ( "Asset", + ( Money.Increase_on_debit, + make + [ + ("Accounts_receivable", make []); + ("Bank", make [ ("Savings", make []); ("Checking", make []) ]); + ("Cash", make []); + ("Mutual_fund", make []); + ("Stock", make []); + ] ) ); + ("Equity", (Money.Increase_on_credit, make [])); + ("Expense", (Money.Increase_on_debit, make [])); + ("Income", (Money.Increase_on_credit, make [])); + ( "Liability", + ( Money.Increase_on_credit, + make [ ("Accounts_payable", make []); ("Credit", make []) ] ) ); + ] + +(* In this module, only the following two function entertains the + option that the given path may not be valid (i.e., it does not + throw an exception for invalid paths). *) +let rec get_node : path -> tree option = + let open Option.Let_syntax in + function + | Base x -> + let%map _, t = Map.find canonical x in + t + | Sub (t, p) -> + let%bind super = get_node p in + Map.find super.car t + +(** Always gives [Some] under valid paths, giving a list of valid paths *) +let children (p : path) : path list = + let node = Option.value_exn (get_node p) in + List.map (Map.keys node.car) ~f:(fun sub -> Sub (sub, p)) + +let sub (p : path) (name : string) : path option = + let node = Option.value_exn (get_node p) in + if Map.mem node.car name then Some (Sub (name, p)) else None + +let super : path -> path option = function + | Base _ -> None + | Sub (_, super) -> Some super + +let rec equal_path p1 p2 = + match (p1, p2) with + | Base x1, Base x2 -> String.(x1 = x2) + | Sub (x1, p1'), Sub (x2, p2') -> String.(x1 = x2) && equal_path p1' p2' + | _, _ -> false + +let is_prefix (p : path) ~(prefix : path) : bool = + List.is_prefix (path_to_list p) ~prefix:(path_to_list prefix) + ~equal:String.equal + +let rec polarity = function + | Base x -> + let pol, _ = Map.find_exn canonical x in + pol + | Sub (_, p') -> polarity p' + +let assert_valid acc = + match get_node acc with None -> failwith "invalid base account" | _ -> acc + +let asset = Base "Asset" |> assert_valid +let equity = Base "Equity" |> assert_valid +let expense = Base "Expense" |> assert_valid +let income = Base "Income" |> assert_valid +let liability = Base "Liability" |> assert_valid diff --git a/lib/account/type_hierarchy.mli b/lib/account/type_hierarchy.mli new file mode 100644 index 0000000..c346628 --- /dev/null +++ b/lib/account/type_hierarchy.mli @@ -0,0 +1,15 @@ +type path +(** The 'kernel' of account types: a hierarchy of valid types. A valid type is a + path that leads to a node in the hierarchy. *) + +val children : path -> path list +val sub : path -> string -> path option +val super : path -> path option +val equal_path : path -> path -> bool +val is_prefix : path -> prefix:path -> bool +val polarity : path -> Money.polarity +val asset : path +val equity : path +val expense : path +val income : path +val liability : path diff --git a/lib/balanced_batch.ml b/lib/balanced_batch.ml new file mode 100644 index 0000000..5a64546 --- /dev/null +++ b/lib/balanced_batch.ml @@ -0,0 +1,42 @@ +open Prelude + +(* Degenerate transactions, which can be applied directly to account + hierarchies (because we ideally want no unsafe operations on + accounts) *) +module Make (K : Map_intf.Key) : sig + type entry = { + dc : Money.Debit_credit.t; + commodity : Money.Commodity_id.t; + amount : Money.Amount.t; + } + + type t + type error = Unbalanced + + val make : entry Map.Make(K).t -> (t, error) result + val entries : t -> entry Map.Make(K).t +end = struct + type entry = { + dc : Money.Debit_credit.t; + commodity : Money.Commodity_id.t; + amount : Money.Amount.t; + } + + type t = entry Map.Make(K).t + type error = Unbalanced + + let is_balanced entries = + Map.fold entries ~init:Money.Commodity_id.Map.empty + ~f:(fun ~key:_ ~data comm_balances -> + Map.update comm_balances data.commodity ~f:(fun ocomm_bal -> + let comm_bal = Option.value ocomm_bal ~default:Money.Diff.(~$0) in + match data.dc with + | Money.Debit_credit.Debit -> Money.Diff.(comm_bal +% data.amount) + | Money.Debit_credit.Credit -> Money.Diff.(comm_bal -% data.amount))) + |> Map.for_all ~f:(fun comm_bal -> Money.Diff.(comm_bal = ~$0)) + + let make entries = + if not (is_balanced entries) then Error Unbalanced else Ok entries + + let entries entries = entries (* ambiguous? I disagree *) +end diff --git a/lib/dune b/lib/dune index 6208dd7..ca9aac2 100644 --- a/lib/dune +++ b/lib/dune @@ -1,3 +1,5 @@ +(include_subdirs qualified) + (library (name rdcapsis) (preprocess diff --git a/lib/money.ml b/lib/money.ml new file mode 100644 index 0000000..a06af64 --- /dev/null +++ b/lib/money.ml @@ -0,0 +1,79 @@ +open Prelude + +type polarity = Increase_on_debit | Increase_on_credit + +module Debit_credit = struct + type t = Debit | Credit [@@deriving string, sexp_of] + + (* let opposite = function Debit -> Credit | Credit -> Debit *) +end + +module Amount : sig + type t + + val equal : t -> t -> bool + val compare : t -> t -> int + val of_bigint : Bigint.t -> t option + val to_bigint : t -> Bigint.t + val ( + ) : t -> t -> t + val ( = ) : t -> t -> bool + val sexp_of_t : t -> Sexp.t + val zero : t +end = struct + type t = Bigint.t [@@deriving sexp_of] + + let equal = Bigint.equal + let compare = Bigint.compare + let of_bigint x = if Bigint.(zero <= x) then Some x else None + let to_bigint x = x + let ( + ) x y = Bigint.(x + y) + let ( = ) = equal + let zero = Bigint.zero +end + +module Diff : sig + type t + + val equal : t -> t -> bool + val compare : t -> t -> int + val of_bigint : Bigint.t -> t + val to_bigint : t -> Bigint.t + val ( + ) : t -> t -> t + val ( +% ) : t -> Amount.t -> t + val ( - ) : t -> t -> t + val ( -% ) : t -> Amount.t -> t + val ( = ) : t -> t -> bool + val neg : t -> t + val ( ~$ ) : int -> t + val sexp_of_t : t -> Sexp.t + val of_amount : Amount.t -> Debit_credit.t -> polarity -> t +end = struct + type t = Bigint.t [@@deriving sexp_of] + + let equal = Bigint.equal + let compare = Bigint.compare + let of_bigint x = x + let to_bigint x = x + let ( + ) x y = Bigint.(x + y) + let ( +% ) x y = x + of_bigint (Amount.to_bigint y) + let ( - ) x y = Bigint.(x - y) + let ( -% ) x y = x - of_bigint (Amount.to_bigint y) + let ( = ) = equal + let neg = Bigint.neg + let ( ~$ ) = Fn.compose of_bigint Bigint.of_int + + let of_amount x (dc : Debit_credit.t) (on_debit : polarity) = + match (dc, on_debit) with + | Debit, Increase_on_debit -> of_bigint (Amount.to_bigint x) + | Credit, Increase_on_debit -> neg (of_bigint (Amount.to_bigint x)) + | Credit, Increase_on_credit -> of_bigint (Amount.to_bigint x) + | Debit, Increase_on_credit -> neg (of_bigint (Amount.to_bigint x)) +end + +module Commodity_id = struct + type t = string [@@deriving equal, compare, sexp] + + module Map = Map.Make (struct + type nonrec t = t [@@deriving equal, compare, sexp] + end) +end -- cgit v1.3