From 40ed2624e13bc519bebe4332a217fd539b76e5f4 Mon Sep 17 00:00:00 2001
From: Rutger Broekhoff
Date: Thu, 8 Jan 2026 02:16:11 +0100
Subject: Type system crimes have been committed

---
 lib/ledger.ml | 334 ++++++++++++++++++++++++++++++++++------------------------
 1 file changed, 194 insertions(+), 140 deletions(-)

(limited to 'lib/ledger.ml')

diff --git a/lib/ledger.ml b/lib/ledger.ml
index 058cc65..3e1d177 100644
--- a/lib/ledger.ml
+++ b/lib/ledger.ml
@@ -182,19 +182,7 @@ type scalar =
   | Rate of { in_primary_commodity : Money.Amount.t; rate : Bigdecimal.t }
 [@@deriving equal, compare, sexp_of] *)
 
-module Account = struct
-  (* The contents of an account of category 'a *)
-  type 'a core =
-    (* Comprises of subaccounts of its subcategories *)
-    | Node of 'a String.Map.t
-    (* Comprises of subaccounts of its own category *)
-    | Ind of 'a t String.Map.t
-    (* Has no subaccounts, has a balance in a certain commodity *)
-    | Leaf of Commodity_id.t * Money.Diff.t
-
-  and extra = { description : String.t }
-  and 'a t = extra * 'a core
-
+module Gh = struct
   (* The category of the five top-level categories *)
   type global
 
@@ -207,92 +195,188 @@ module Account = struct
 
   (* No subcategories *)
   type final
+end
 
-  (* Subaccounts under the five top-level categories *)
+module Account_structure0 (F : sig
+  type 'a t
+end) =
+struct
   type 'a f =
-    | Accounts_payable : final f t -> liability f
-    | Accounts_receivable : final f t -> asset f
-    | Bank : final f t -> asset f
-    | Cash : final f t -> asset f
-    | Credit : final f t -> liability f
-    | Mutual_fund : final f t -> asset f
-    | Stock : final f t -> asset f
-
-  module Ft_mapper = struct
-    type nonrec 'b t = { car : 'a. 'a f t -> ('b * 'a f t) option }
-
-    let map (type b c) (f : c t) : b f -> (c * b f) option =
+    | Accounts_payable : Gh.final f F.t -> Gh.liability f
+    | Accounts_receivable : Gh.final f F.t -> Gh.asset f
+    | Bank : Gh.final f F.t -> Gh.asset f
+    | Cash : Gh.final f F.t -> Gh.asset f
+    | Credit : Gh.final f F.t -> Gh.liability f
+    | Mutual_fund : Gh.final f F.t -> Gh.asset f
+    | Stock : Gh.final f F.t -> Gh.asset f
+
+  type t0 =
+    | Asset of Gh.asset f F.t
+    | Equity of Gh.equity f F.t
+    | Expense of Gh.expense f F.t
+    | Income of Gh.income f F.t
+    | Liability of Gh.liability f F.t
+end
+
+module Account_type = struct
+  type 'a elem = Leaf | Node of 'a
+
+  include Account_structure0 (struct
+    type 'a t = 'a elem
+  end)
+end
+
+module Account_structure (F : sig
+  type 'a t
+end) =
+struct
+  include Account_structure0 (F)
+
+  module Mapper = struct
+    type nonrec 'b t = {
+      car :
+        'a.
+        'a f F.t ->
+        ('a Account_type.f Account_type.elem -> Account_type.t0) ->
+        ('b * 'a f F.t) option;
+    }
+
+    let map (type b c) (f : c t) (mkt : b Account_type.f -> Account_type.t0) :
+        b f -> (c * b f) option =
       let open Option.Let_syntax in
       function
       | Accounts_payable v ->
-          let%map c, v' = f.car v in
+          let%map c, v' =
+            f.car v (fun el -> mkt (Account_type.Accounts_payable el))
+          in
           (c, Accounts_payable v')
       | Accounts_receivable v ->
-          let%map c, v' = f.car v in
+          let%map c, v' =
+            f.car v (fun el -> mkt (Account_type.Accounts_receivable el))
+          in
           (c, Accounts_receivable v')
       | Bank v ->
-          let%map c, v' = f.car v in
+          let%map c, v' = f.car v (fun el -> mkt (Account_type.Bank el)) in
           (c, Bank v')
       | Cash v ->
-          let%map c, v' = f.car v in
+          let%map c, v' = f.car v (fun el -> mkt (Account_type.Cash el)) in
           (c, Cash v')
       | Credit v ->
-          let%map c, v' = f.car v in
+          let%map c, v' = f.car v (fun el -> mkt (Account_type.Credit el)) in
           (c, Credit v')
       | Mutual_fund v ->
-          let%map c, v' = f.car v in
+          let%map c, v' =
+            f.car v (fun el -> mkt (Account_type.Mutual_fund el))
+          in
           (c, Mutual_fund v')
       | Stock v ->
-          let%map c, v' = f.car v in
+          let%map c, v' = f.car v (fun el -> mkt (Account_type.Stock el)) in
           (c, Stock v')
   end
+end
 
-  module Top_level (F : sig
-    type 'a t
-  end) =
-  struct
-    type t =
-      | Asset of asset F.t
-      | Equity of equity F.t
-      | Expense of expense F.t
-      | Income of income F.t
-      | Liability of liability F.t
-  end
+module Typed_account_path = struct
+  type 'a elem = Leaf | Node of string * 'a | Ind of string * 'a elem
 
-  module Top_level_type = Top_level (struct
-    type nonrec 'a t = unit
+  include Account_structure (struct
+    type 'a t = 'a elem
   end)
+end
 
-  (* I swear the bullshit stops here *)
-  module F0 = struct
-    include Top_level (struct
-      type nonrec 'a t = 'a f t
-    end)
-
-    let type_ : t -> Top_level_type.t = function
-      | Asset _ -> Asset ()
-      | Equity _ -> Equity ()
-      | Expense _ -> Expense ()
-      | Income _ -> Income ()
-      | Liability _ -> Liability ()
-  end
+module Account_path = struct
+  type t = string list [@@deriving compare, sexp]
+
+  module Map = Map.Make (struct
+    type nonrec t = t [@@deriving compare, sexp]
+  end)
+end
+
+module Account_hierarchy = struct
+  (* The contents of an account of category 'a *)
+  type 'a core =
+    (* Comprises of subaccounts of its subcategories *)
+    | Node of 'a String.Map.t
+    (* Comprises of subaccounts of its own category *)
+    | Ind of 'a account String.Map.t
+    (* Has no subaccounts, has a balance in a certain commodity *)
+    | Leaf of Commodity_id.t * Money.Diff.t
+
+  and extra = { description : String.t }
+  and 'a account = extra * 'a core
+
+  include Account_structure (struct
+    type 'a t = 'a account
+  end)
 
   (* All accounts *)
-  type world = F0.t String.Map.t
+  type world = t0 String.Map.t
 
-  module Path = struct
-    type t = string list [@@deriving compare, sexp]
+  let rec alter_aux (subaid : Account_path.t)
+      (f :
+        Account_type.t0 -> Commodity_id.t -> Money.Diff.t -> 'a * Money.Diff.t)
+      : 'a Mapper.t =
+    {
+      car =
+        (fun in_acc mkt ->
+          let open Option.Let_syntax in
+          match (subaid, in_acc) with
+          | [], (extra, Leaf (acc_comm, acc_bal)) ->
+              let x, acc_bal' = f (mkt Account_type.Leaf) acc_comm acc_bal in
+              Some (x, (extra, Leaf (acc_comm, acc_bal')))
+          | [], _ -> None
+          | subaid0 :: subaid, (extra, Node subaccs) ->
+              let open Option.Let_syntax in
+              let%bind subacc = Map.find subaccs subaid0 in
+              let%map x, subacc' =
+                Mapper.map (alter_aux subaid f) (fun k -> mkt (Node k)) subacc
+              in
+              (x, (extra, Node (Map.set subaccs ~key:subaid0 ~data:subacc')))
+          | subaid0 :: subaid, (extra, Ind subaccs) ->
+              let open Option.Let_syntax in
+              let%bind subacc = Map.find subaccs subaid0 in
+              let%map x, subacc' = (alter_aux subaid f).car subacc mkt in
+              (x, (extra, Ind (Map.set subaccs ~key:subaid0 ~data:subacc')))
+          | _ :: _, (_, Leaf _) -> None);
+    }
 
-    module Map = Map.Make (struct
-      type nonrec t = t [@@deriving compare, sexp]
-    end)
-  end
+  let alter (aid : Account_path.t)
+      (f :
+        Account_type.t0 -> Commodity_id.t -> Money.Diff.t -> 'a * Money.Diff.t)
+      (w : world) : ('a * world) option =
+    match aid with
+    | [] -> None
+    | aid0 :: subaid -> (
+        let open Option.Let_syntax in
+        match%bind Map.find w aid0 with
+        | Asset acc ->
+            let%map x, acc' = (alter_aux subaid f).car acc (fun k -> Asset k) in
+            (x, Map.set w ~key:aid0 ~data:(Asset acc'))
+        | Expense acc ->
+            let%map x, acc' =
+              (alter_aux subaid f).car acc (fun k -> Expense k)
+            in
+            (x, Map.set w ~key:aid0 ~data:(Expense acc'))
+        | Income acc ->
+            let%map x, acc' =
+              (alter_aux subaid f).car acc (fun k -> Income k)
+            in
+            (x, Map.set w ~key:aid0 ~data:(Income acc'))
+        | Liability acc ->
+            let%map x, acc' =
+              (alter_aux subaid f).car acc (fun k -> Liability k)
+            in
+            (x, Map.set w ~key:aid0 ~data:(Liability acc'))
+        | Equity acc ->
+            let%map x, acc' =
+              (alter_aux subaid f).car acc (fun k -> Equity k)
+            in
+            (x, Map.set w ~key:aid0 ~data:(Equity acc')))
 
   let world_inst : world =
     String.Map.of_alist_exn
       [
         ( "Assets",
-          F0.Asset
+          Asset
             ( { description = "assets" },
               Ind
                 (String.Map.of_alist_exn
@@ -323,7 +407,7 @@ module Account = struct
 end
 
 type bal_assert = {
-  account : Account.Path.t;
+  account : Account_path.t;
   labels : Labels.t;
   bal : Money.Diff.t;
 }
@@ -340,7 +424,7 @@ module Tx : sig
   (* Private because we only want to allow constructing balanced transactions. *)
   type t = private {
     cleared : Date.t option;
-    entries : entry Account.Path.Map.t;
+    entries : entry Account_path.Map.t;
     labels : Labels.t;
   }
 
@@ -348,7 +432,7 @@ module Tx : sig
 
   val make :
     cleared:Date.t option ->
-    entries:entry Account.Path.Map.t ->
+    entries:entry Account_path.Map.t ->
     labels:Labels.t ->
     (t, error) result
 
@@ -364,7 +448,7 @@ end = struct
 
   type t = {
     cleared : Date.t option;
-    entries : entry Account.Path.Map.t;
+    entries : entry Account_path.Map.t;
     labels : Labels.t;
   }
   [@@deriving sexp_of]
@@ -394,87 +478,57 @@ type item =
 type t = item list [@@deriving sexp_of]
 
 module World = struct
-  type t = Account.world
+  type t = Account_hierarchy.world
 
   let empty : t = String.Map.empty
 
-  let update_bal_fn = (f :
-        Account.Top_level_type.t ->
-        Commodity_id.t ->
-        Money.Diff.t ->
-        ('a * Money.Diff.t) option)
-  
-  (* Stretching the type system a little :) *)
-  let rec update_bal_aux ttype subaid
-      (f :
-        Account.Top_level_type.t ->
-        Commodity_id.t ->
-        Money.Diff.t ->
-        ('a * Money.Diff.t) option) : 'a Account.Ft_mapper.t =
-    {
-      car =
-        (fun in_acc ->
-          let open Option.Let_syntax in
-          match (subaid, in_acc) with
-          | [], (extra, Account.Leaf (acc_comm, acc_bal)) ->
-              let%bind x, acc_bal' = f ttype acc_comm acc_bal in
-              Some (x, (extra, Account.Leaf (acc_comm, acc_bal')))
-          | [], _ -> None
-          | subaid0 :: subaid, (extra, Node subaccs) ->
-              let open Option.Let_syntax in
-              let%bind subacc = Map.find subaccs subaid0 in
-              let%map x, subacc' =
-                Account.Ft_mapper.map (update_bal_aux ttype subaid f) subacc
-              in
-              ( x,
-                ( extra,
-                  Account.Node (Map.set subaccs ~key:subaid0 ~data:subacc') ) )
-          | subaid0 :: subaid, (extra, Ind subaccs) ->
-              let open Option.Let_syntax in
-              let%bind subacc = Map.find subaccs subaid0 in
-              let%map x, subacc' = (update_bal_aux ttype subaid f).car subacc in
-              ( x,
-                (extra, Account.Ind (Map.set subaccs ~key:subaid0 ~data:subacc'))
-              )
-          | _ :: _, (_, Leaf _) -> None);
-    }
-
   (** Update the balance (debit/credit ([dc])) of account [aid] [by_amount]
       (commodity: [in_comm]) in [world], giving the updated world and the pre
       and post balances for [aid] iff the account exists in [world]. *)
   let update_bal aid dc by_amount in_comm (world : t) :
-      ((Money.Diff.t * Money.Diff.t) * t) option =
-    match aid with
-    | [] -> None
-    | aid0 :: subaid -> (
-        let open Option.Let_syntax in
-        match%bind Map.find world aid0 with
-        | Asset acc ->
-            let diff = Money.Diff.of_amount by_amount dc ~on_debit:`Incr in
-            let%map bals, acc' = (update_bal_aux subaid diff in_comm).car acc in
-            (bals, Map.set world ~key:aid0 ~data:(Asset acc'))
-        | Expense acc ->
-            let diff = Money.Diff.of_amount by_amount dc ~on_debit:`Incr in
-            let%map bals, acc' = (update_bal_aux subaid diff in_comm).car acc in
-            (bals, Map.set world ~key:aid0 ~data:(Expense acc'))
-        | Income acc ->
-            let diff = Money.Diff.of_amount by_amount dc ~on_debit:`Decr in
-            let%map bals, acc' = (update_bal_aux subaid diff in_comm).car acc in
-            (bals, Map.set world ~key:aid0 ~data:(Income acc'))
-        | Liability acc ->
-            let diff = Money.Diff.of_amount by_amount dc ~on_debit:`Decr in
-            let%map bals, acc' = (update_bal_aux subaid diff in_comm).car acc in
-            (bals, Map.set world ~key:aid0 ~data:(Liability acc'))
-        | Equity acc ->
-            let diff = Money.Diff.of_amount by_amount dc ~on_debit:`Decr in
-            let%map bals, acc' = (update_bal_aux subaid diff in_comm).car acc in
-            (bals, Map.set world ~key:aid0 ~data:(Equity acc')))
+      (Money.Diff.t * Money.Diff.t * t) option =
+    let open Option.Let_syntax in
+    let%bind mres, world' =
+      Account_hierarchy.alter aid
+        (fun acc_type acc_comm acc_bal ->
+          if not ([%equal: Commodity_id.t] acc_comm in_comm) then (None, acc_bal)
+          else
+            match acc_type with
+            | Asset _ ->
+                let acc_bal' =
+                  Money.Diff.(acc_bal + of_amount by_amount dc ~on_debit:`Incr)
+                in
+                (Some (acc_bal, acc_bal'), acc_bal')
+            | Expense _ ->
+                let acc_bal' =
+                  Money.Diff.(acc_bal + of_amount by_amount dc ~on_debit:`Incr)
+                in
+                (Some (acc_bal, acc_bal'), acc_bal')
+            | Income _ ->
+                let acc_bal' =
+                  Money.Diff.(acc_bal + of_amount by_amount dc ~on_debit:`Decr)
+                in
+                (Some (acc_bal, acc_bal'), acc_bal')
+            | Liability _ ->
+                let acc_bal' =
+                  Money.Diff.(acc_bal + of_amount by_amount dc ~on_debit:`Decr)
+                in
+                (Some (acc_bal, acc_bal'), acc_bal')
+            | Equity _ ->
+                let acc_bal' =
+                  Money.Diff.(acc_bal + of_amount by_amount dc ~on_debit:`Decr)
+                in
+                (Some (acc_bal, acc_bal'), acc_bal'))
+        world
+    in
+    let%map pre_bal, post_bal = mres in
+    (pre_bal, post_bal, world')
 
   let apply_tx (tx : Tx.t) world : t option =
     Map.fold_option tx.entries ~init:world
       ~f:(fun ~key:aid ~(data : Tx.entry) world ->
         let open Option.Let_syntax in
-        let%bind (_old_bal, new_bal), world =
+        let%bind _old_bal, new_bal, world =
           update_bal aid data.dc data.amount data.commodity world
         in
         match data.assertion with
-- 
cgit v1.2.3