From 6ebee5d82d3674fe50609b308d1eaf3cdac101d1 Mon Sep 17 00:00:00 2001
From: Rutger Broekhoff
Date: Fri, 9 Jan 2026 11:45:02 +0100
Subject: I have no idea what I'm doing

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

(limited to 'lib')

diff --git a/lib/ledger.ml b/lib/ledger.ml
index 7de131f..928570f 100644
--- a/lib/ledger.ml
+++ b/lib/ledger.ml
@@ -182,62 +182,85 @@ type scalar =
   | Rate of { in_primary_commodity : Money.Amount.t; rate : Bigdecimal.t }
 [@@deriving equal, compare, sexp_of] *)
 
-module Gh = struct
-  (* The category of the five top-level categories *)
-  type global
-
-  (* The five top-level categories *)
-  type asset [@@deriving sexp_of]
-  type equity [@@deriving sexp_of]
-  type expense [@@deriving sexp_of]
-  type income [@@deriving sexp_of]
-  type liability [@@deriving sexp_of]
-
-  (* Subcategories of assets *)
-  type bank [@@deriving sexp_of]
-
-  (* No subcategories *)
-  type final [@@deriving sexp_of]
-end
+module Account_structure0 = struct
+  module Categories = struct
+    (* The five top-level categories *)
+    type asset [@@deriving sexp_of]
+    type equity [@@deriving sexp_of]
+    type expense [@@deriving sexp_of]
+    type income [@@deriving sexp_of]
+    type liability [@@deriving sexp_of]
+
+    (* Subcategories of assets *)
+    type bank [@@deriving sexp_of]
+
+    (* No subcategories *)
+    type final [@@deriving sexp_of]
+  end
 
-module Account_structure0 (F : sig
-  type 'a t [@@deriving sexp_of]
-end) =
-struct
-  type 'a f =
-    | Accounts_payable : Gh.final f F.t -> Gh.liability f
-    | Accounts_receivable : Gh.final f F.t -> Gh.asset f
-    | Bank : Gh.bank 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
-    | Savings : Gh.final f F.t -> Gh.bank f
-    | Checking : Gh.final f F.t -> Gh.bank f
-  [@@deriving sexp_of]
+  module type Scaffold = sig
+    type 'a t [@@deriving sexp_of]
+  end
 
-  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
-  [@@deriving sexp_of]
+  module type S = sig
+    include Scaffold
+
+    type 'a f =
+      | Accounts_payable : Categories.final f t -> Categories.liability f
+      | Accounts_receivable : Categories.final f t -> Categories.asset f
+      | Bank : Categories.bank f t -> Categories.asset f
+      | Cash : Categories.final f t -> Categories.asset f
+      | Credit : Categories.final f t -> Categories.liability f
+      | Mutual_fund : Categories.final f t -> Categories.asset f
+      | Stock : Categories.final f t -> Categories.asset f
+      | Savings : Categories.final f t -> Categories.bank f
+      | Checking : Categories.final f t -> Categories.bank f
+    [@@deriving sexp_of]
+
+    type t0 =
+      | Asset of Categories.asset f t
+      | Equity of Categories.equity f t
+      | Expense of Categories.expense f t
+      | Income of Categories.income f t
+      | Liability of Categories.liability f t
+    [@@deriving sexp_of]
+  end
+
+  module Make (F : Scaffold) : S with type 'a t = 'a F.t = struct
+    include F
+
+    type 'a f =
+      | Accounts_payable : Categories.final f F.t -> Categories.liability f
+      | Accounts_receivable : Categories.final f F.t -> Categories.asset f
+      | Bank : Categories.bank f F.t -> Categories.asset f
+      | Cash : Categories.final f F.t -> Categories.asset f
+      | Credit : Categories.final f F.t -> Categories.liability f
+      | Mutual_fund : Categories.final f F.t -> Categories.asset f
+      | Stock : Categories.final f F.t -> Categories.asset f
+      | Savings : Categories.final f F.t -> Categories.bank f
+      | Checking : Categories.final f F.t -> Categories.bank f
+    [@@deriving sexp_of]
+
+    type t0 =
+      | Asset of Categories.asset f F.t
+      | Equity of Categories.equity f F.t
+      | Expense of Categories.expense f F.t
+      | Income of Categories.income f F.t
+      | Liability of Categories.liability f F.t
+    [@@deriving sexp_of]
+  end
 end
 
 module Account_type = struct
   type 'a elem = Leaf | Node of 'a [@@deriving sexp_of]
 
-  include Account_structure0 (struct
+  include Account_structure0.Make (struct
     type 'a t = 'a elem [@@deriving sexp_of]
   end)
 end
 
-module Account_structure (F : sig
-  type 'a t [@@deriving sexp_of]
-end) =
-struct
-  include Account_structure0 (F)
+module Account_structure (F : Account_structure0.Scaffold) = struct
+  include Account_structure0.Make (F)
 
   module Mapper = struct
     type nonrec 'b t = {
@@ -301,6 +324,33 @@ struct
       | Savings v -> f.car v
       | Checking v -> f.car v
   end
+
+  module Folder2 (H : Account_structure0.S) = struct
+    module type Recons = sig
+      type inner
+      type outer
+
+      module type Make = functor (G : Account_structure0.S) -> sig
+        val recons : inner G.f G.t -> outer G.f
+      end
+    end
+
+    type nonrec ('outer, 'acc) t = {
+      car : 'inner. 'inner f F.t -> ('inner H.f H.t -> 'outer H.f) -> 'acc;
+    }
+
+    let fold (type a acc) (f : (a, acc) t) : a f -> acc = function
+      | Accounts_payable v -> f.car v (fun inner -> H.Accounts_payable inner)
+      | Accounts_receivable v ->
+          f.car v (fun inner -> H.Accounts_receivable inner)
+      | Bank v -> f.car v (fun inner -> H.Bank inner)
+      | Cash v -> f.car v (fun inner -> H.Cash inner)
+      | Credit v -> f.car v (fun inner -> H.Credit inner)
+      | Mutual_fund v -> f.car v (fun inner -> H.Mutual_fund inner)
+      | Stock v -> f.car v (fun inner -> H.Stock inner)
+      | Savings v -> f.car v (fun inner -> H.Savings inner)
+      | Checking v -> f.car v (fun inner -> H.Checking inner)
+  end
 end
 
 module Typed_account_path = struct
-- 
cgit v1.2.3