1 files changed, 49 insertions, 93 deletions

diff --git a/lib/ledger.ml b/lib/ledger.ml
index 7bb824c..115588a 100644
--- a/lib/ledger.ml
+++ b/lib/ledger.ml
@@ -253,103 +253,16 @@ module Account_structure0 = struct
 module Account_type = struct
   type 'a elem = Leaf | Node of 'a [@@deriving sexp_of]
 
-  include Account_structure0.Make (struct
+  module Scaffold = struct
     type 'a t = 'a elem [@@deriving sexp_of]
-  end)
-end
-
-module Account_structure (F : Account_structure0.Scaffold) = struct
-  include Account_structure0.Make (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 (fun el -> mkt (Account_type.Accounts_payable el))
-          in
-          (c, Accounts_payable v')
-      | Accounts_receivable v ->
-          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 (fun el -> mkt (Account_type.Bank el)) in
-          (c, Bank v')
-      | Cash v ->
-          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 (fun el -> mkt (Account_type.Credit el)) in
-          (c, Credit v')
-      | Mutual_fund v ->
-          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 (fun el -> mkt (Account_type.Stock el)) in
-          (c, Stock v')
-      | Savings v ->
-          let%map c, v' = f.car v (fun el -> mkt (Account_type.Savings el)) in
-          (c, Savings v')
-      | Checking v ->
-          let%map c, v' = f.car v (fun el -> mkt (Account_type.Checking el)) in
-          (c, Checking v')
-  end
-
-  module Folder = struct
-    type nonrec 'b t = { car : 'a. 'a f F.t -> 'b }
-
-    let fold (type b c) (f : c t) : b f -> c = function
-      | Accounts_payable v -> f.car v
-      | Accounts_receivable v -> f.car v
-      | Bank v -> f.car v
-      | Cash v -> f.car v
-      | Credit v -> f.car v
-      | Mutual_fund v -> f.car v
-      | Stock v -> f.car v
-      | Savings v -> f.car v
-      | Checking v -> f.car v
   end
 
-  module Folder2 = struct
-    type nonrec ('outer, 'acc) t = {
-      car :
-        'inner.
-        'inner f F.t ->
-        (module Account_structure0.Gen_f_cons.S
-           with type inner = 'inner
-            and type outer = 'outer) ->
-        'acc;
-    }
+  include Account_structure0.Make (Scaffold)
+end
 
-    let fold (type a acc) (f : (a, acc) t) : a f -> acc = function
-      | Accounts_payable v ->
-          f.car v (module Account_structure0.Gen_f_cons.Accounts_payable)
-      | _ -> failwith "kaas"
-    (*
-      | 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
+module Account_structure (F : Account_structure0.Scaffold) = struct
+  module Structure = Account_structure0.Make (F)
+  include Structure
 
   module Folder3 (Acc : sig
     type 'a t
@@ -380,6 +293,49 @@ module Account_structure (F : Account_structure0.Scaffold) = struct
       | Savings v -> f.car v (fun inner -> H.Savings inner)
       | Checking v -> f.car v (fun inner -> H.Checking inner) *)
   end
+
+  module Folder = struct
+    type nonrec 'b t = { car : 'a. 'a f F.t -> 'b }
+
+    let fold (type b c) (f : c t) : b f -> c =
+      let module Inst = Folder3 (struct
+        type 'a t = c
+      end) in
+      Inst.fold { car = (fun v _cons -> f.car v) }
+  end
+
+  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 module Inst = Folder3 (struct
+        type 'b t = (c * 'b f) option
+      end) in
+      Inst.fold
+        {
+          car =
+            (fun (type inner)
+              v
+              (module Gen_cons : Account_structure0.Gen_f_cons.S
+                with type inner = inner
+                 and type outer = b)
+            ->
+              let open Option.Let_syntax in
+              let module Type_cons =
+                Gen_cons.Specialize (Account_type.Scaffold) (Account_type)
+              in
+              let module Own_cons = Gen_cons.Specialize (F) (Structure) in
+              let%map c, v' = f.car v (fun el -> mkt (Type_cons.cons el)) in
+              (c, Own_cons.cons v'));
+        }
+  end
 end
 
 module Typed_account_path = struct