oha!

4 files changed, 234 insertions, 0 deletions

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