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/account.ml | 121 +++++++++++++++++++++++++++++++++++++++++ lib/account/type.ml | 15 +++++ lib/account/type_hierarchy.ml | 83 ++++++++++++++++++++++++++++ lib/account/type_hierarchy.mli | 15 +++++ 4 files changed, 234 insertions(+) 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 (limited to 'lib/account') 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 -- cgit v1.3