pre-destruction commit

2 files changed, 364 insertions, 113 deletions

diff --git a/lib/ledger.ml b/lib/ledger.ml
index 7805179..058cc65 100644
--- a/lib/ledger.ml
+++ b/lib/ledger.ml
@@ -96,72 +96,251 @@ module Labels = struct
     | Sexp.Atom _ -> of_sexp_error "Labels.t_of_sexp: list needed" sexp
 end
 
-module Money : sig
-  type t
-
-  val equal : t -> t -> bool
-  val compare : t -> t -> int
-  val of_bigint : Bigint.t -> t
-  val to_bigint : t -> Bigint.t
-  val ( + ) : t -> t -> t
-  val ( - ) : t -> t -> t
-  val ( = ) : t -> t -> bool
-  val ( ~$ ) : int -> t
-  val sexp_of_t : t -> Sexp.t
-end = struct
-  type t = Bigint.t [@@deriving sexp_of]
-
-  let equal = Bigint.equal
-  let compare = Bigint.compare
-  let of_bigint = Fn.id
-  let to_bigint = Fn.id
-  let ( + ) x y = Bigint.(x + y)
-  let ( - ) x y = Bigint.(x - y)
-  let ( = ) = equal
-  let ( ~$ ) = Fn.compose of_bigint Bigint.of_int
+module Debit_credit = struct
+  type t = Debit | Credit [@@deriving string, sexp_of]
+
+  (*  let opposite = function Debit -> Credit | Credit -> Debit *)
 end
 
-type commodity_id = string
-(* TODO: consider making this UUID *) [@@deriving equal, compare, sexp]
+module Money = struct
+  module Amount : sig
+    type t
+
+    val equal : t -> t -> bool
+    val compare : t -> t -> int
+    val of_bigint : Bigint.t -> t option
+    val to_bigint : t -> Bigint.t
+    val ( + ) : t -> t -> t
+    val ( = ) : t -> t -> bool
+    val sexp_of_t : t -> Sexp.t
+    val zero : t
+  end = struct
+    type t = Bigint.t [@@deriving sexp_of]
+
+    let equal = Bigint.equal
+    let compare = Bigint.compare
+    let of_bigint x = if Bigint.(zero <= x) then Some x else None
+    let to_bigint x = x
+    let ( + ) x y = Bigint.(x + y)
+    let ( = ) = equal
+    let zero = Bigint.zero
+  end
+
+  module Diff : sig
+    type t
+
+    val equal : t -> t -> bool
+    val compare : t -> t -> int
+    val of_bigint : Bigint.t -> t
+    val to_bigint : t -> Bigint.t
+    val ( + ) : t -> t -> t
+    val ( +% ) : t -> Amount.t -> t
+    val ( - ) : t -> t -> t
+    val ( -% ) : t -> Amount.t -> t
+    val ( = ) : t -> t -> bool
+    val neg : t -> t
+    val ( ~$ ) : int -> t
+    val sexp_of_t : t -> Sexp.t
+
+    val of_amount :
+      Amount.t -> Debit_credit.t -> on_debit:[ `Incr | `Decr ] -> t
+  end = struct
+    type t = Bigint.t [@@deriving sexp_of]
+
+    let equal = Bigint.equal
+    let compare = Bigint.compare
+    let of_bigint x = x
+    let to_bigint x = x
+    let ( + ) x y = Bigint.(x + y)
+    let ( +% ) x y = x + of_bigint (Amount.to_bigint y)
+    let ( - ) x y = Bigint.(x - y)
+    let ( -% ) x y = x - of_bigint (Amount.to_bigint y)
+    let ( = ) = equal
+    let neg = Bigint.neg
+    let ( ~$ ) = Fn.compose of_bigint Bigint.of_int
+
+    let of_amount x (dc : Debit_credit.t) ~on_debit =
+      match (dc, on_debit) with
+      | Debit, `Incr -> of_bigint (Amount.to_bigint x)
+      | Credit, `Incr -> neg (of_bigint (Amount.to_bigint x))
+      | Debit, `Decr -> neg (of_bigint (Amount.to_bigint x))
+      | Credit, `Decr -> of_bigint (Amount.to_bigint x)
+  end
+end
 
-type scalar =
-  | Amount of Money.t
-  | Rate of { in_primary_commodity : Money.t; rate : Bigdecimal.t }
-[@@deriving equal, compare, sexp_of]
+module Commodity_id = struct
+  type t = string [@@deriving equal, compare, sexp]
 
-module Account_id = struct
-  type t = string list [@@deriving sexp, compare]
+  module Map = Map.Make (struct
+    type nonrec t = t [@@deriving equal, compare, sexp]
+  end)
 end
 
-type account = {
-  id : Account_id.t;
-  description : string list;
-  commodity_id : commodity_id;
-  balance : Money.t;
-}
-[@@deriving sexp_of]
+(*
+type scalar =
+  | Amount of Money.Amount.t
+  | 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
+
+  (* The category of the five top-level categories *)
+  type global
+
+  (* The five top-level categories *)
+  type asset
+  type equity
+  type expense
+  type income
+  type liability
+
+  (* No subcategories *)
+  type final
+
+  (* Subaccounts under the five top-level categories *)
+  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 =
+      let open Option.Let_syntax in
+      function
+      | Accounts_payable v ->
+          let%map c, v' = f.car v in
+          (c, Accounts_payable v')
+      | Accounts_receivable v ->
+          let%map c, v' = f.car v in
+          (c, Accounts_receivable v')
+      | Bank v ->
+          let%map c, v' = f.car v in
+          (c, Bank v')
+      | Cash v ->
+          let%map c, v' = f.car v in
+          (c, Cash v')
+      | Credit v ->
+          let%map c, v' = f.car v in
+          (c, Credit v')
+      | Mutual_fund v ->
+          let%map c, v' = f.car v in
+          (c, Mutual_fund v')
+      | Stock v ->
+          let%map c, v' = f.car v in
+          (c, Stock v')
+  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 Top_level_type = Top_level (struct
+    type nonrec 'a t = unit
+  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
+
+  (* All accounts *)
+  type world = F0.t String.Map.t
+
+  module Path = struct
+    type t = string list [@@deriving compare, sexp]
+
+    module Map = Map.Make (struct
+      type nonrec t = t [@@deriving compare, sexp]
+    end)
+  end
+
+  let world_inst : world =
+    String.Map.of_alist_exn
+      [
+        ( "Assets",
+          F0.Asset
+            ( { description = "assets" },
+              Ind
+                (String.Map.of_alist_exn
+                   [
+                     ( "Current",
+                       ( { description = "current" },
+                         Node
+                           (String.Map.of_alist_exn
+                              [
+                                ( "Checking",
+                                  Bank
+                                    ( { description = "bnak accounts" },
+                                      Ind
+                                        (String.Map.of_alist_exn
+                                           [
+                                             ( "ING",
+                                               ( { description = "ING bank" },
+                                                 Leaf ("EUC", Money.Diff.(~$0))
+                                               ) );
+                                             ( "N26",
+                                               ( { description = "ING bank" },
+                                                 Leaf ("EUC", Money.Diff.(~$0))
+                                               ) );
+                                           ]) ) );
+                              ]) ) );
+                   ]) ) );
+      ]
+end
 
 type bal_assert = {
-  account : Account_id.t;
-  amount : Money.t;
+  account : Account.Path.t;
   labels : Labels.t;
+  bal : Money.Diff.t;
 }
 [@@deriving sexp_of]
 
-module Account_id_map = Map.Make (Account_id)
-
-module Debit_credit = struct
-  type t = Debit | Credit [@@deriving string, sexp_of]
-
-  let opposite = function Debit -> Credit | Credit -> Debit
-end
-
 module Tx : sig
+  type entry = {
+    dc : Debit_credit.t;
+    commodity : Commodity_id.t;
+    amount : Money.Amount.t;
+    assertion : Money.Diff.t option;
+  }
+
   (* Private because we only want to allow constructing balanced transactions. *)
   type t = private {
     cleared : Date.t option;
-    commodity_id : commodity_id;
-    entries : (Debit_credit.t * scalar * Money.t option) Account_id_map.t;
+    entries : entry Account.Path.Map.t;
     labels : Labels.t;
   }
 
@@ -169,17 +348,23 @@ module Tx : sig
 
   val make :
     cleared:Date.t option ->
-    commodity_id:commodity_id ->
-    entries:(Debit_credit.t * scalar * Money.t option) Account_id_map.t ->
+    entries:entry Account.Path.Map.t ->
     labels:Labels.t ->
     (t, error) result
 
   val sexp_of_t : t -> Sexp.t
 end = struct
+  type entry = {
+    dc : Debit_credit.t;
+    commodity : Commodity_id.t;
+    amount : Money.Amount.t;
+    assertion : Money.Diff.t option;
+  }
+  [@@deriving sexp_of]
+
   type t = {
     cleared : Date.t option;
-    commodity_id : commodity_id;
-    entries : (Debit_credit.t * scalar * Money.t option) Account_id_map.t;
+    entries : entry Account.Path.Map.t;
     labels : Labels.t;
   }
   [@@deriving sexp_of]
@@ -187,22 +372,18 @@ end = struct
   type error = Unbalanced
 
   let is_balanced entries =
-    Map.fold entries
-      ~init:Money.(~$0, ~$0)
-      ~f:(fun ~key:_ ~data:(type_, scalar, _oassert) (ds, cs) ->
-        let m =
-          match scalar with
-          | Amount m -> m
-          | Rate { in_primary_commodity = m; _ } -> m
-        in
-        match type_ with
-        | Debit_credit.Debit -> Money.(ds + m, cs)
-        | Debit_credit.Credit -> Money.(ds, cs + m))
-    |> fun (ds, cs) -> Money.(ds = cs)
-
-  let make ~cleared ~commodity_id ~entries ~labels =
+    Map.fold entries ~init:Commodity_id.Map.empty
+      ~f:(fun ~key:_ ~data comm_balances ->
+        Map.update comm_balances data.commodity ~f:(fun ocomm_bal ->
+            let comm_bal = Option.value ocomm_bal ~default:Money.Diff.(~$0) in
+            match data.dc with
+            | Debit_credit.Debit -> Money.Diff.(comm_bal +% data.amount)
+            | Debit_credit.Credit -> Money.Diff.(comm_bal -% data.amount)))
+    |> Map.for_all ~f:(fun comm_bal -> Money.Diff.(comm_bal = ~$0))
+
+  let make ~cleared ~entries ~labels =
     if not (is_balanced entries) then Error Unbalanced
-    else Ok { cleared; commodity_id; entries; labels }
+    else Ok { cleared; entries; labels }
 end
 
 type item =
@@ -212,53 +393,100 @@ type item =
 
 type t = item list [@@deriving sexp_of]
 
-module Account = struct
-  type global_type = Asset | Equity | Liability | Expense | Income
-  [@@deriving compare, sexp]
-
-  type asset
-  type global
-
-  type 'a subcategory =
-    | Asset : asset subcategory option -> global subcategory
-    | Checking : asset subcategory
-
-  type 'a t = Sub of ('a, 'a t) category String.Map.t
-
-  let world : global t =
-    Sub
-      (String.Map.of_alist_exn [ ("Assets", Asset (Some (
-           String.Map.of_alist_exn [
-             ("Checking", Checking)
-           ]
-         ))) ])
-end
-
-(*
 module World = struct
-  type t = (commodity_id * Money.t) Account_id_map.t
-
-  let empty : t = Account_id_map.empty
-
-  let apply_tx_entry_base aid primary_commodity debit_credit scalar =
-    let amount = Scalar.to_amount ~commodity:primary_commodity scalar in
-    Map.update aid ~f:(function
-          | None -> 
-
-            (*
-  let assert_bal aid sc world =
-
-  let apply_tx_entry aid (dc, sc, oassert) world = *)
-
-  let apply_tx (tx : Tx.t) world =
-    Map.fold tx.entries ~init:world ~f:(fun ~key:account_id ~data:(type_, scalar, _oassert) world ->
-        
-
-      )
+  type t = Account.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')))
+
+  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 =
+          update_bal aid data.dc data.amount data.commodity world
+        in
+        match data.assertion with
+        | None -> Some world
+        | Some bal_ass ->
+            if Money.Diff.(bal_ass = new_bal) then Some world else None)
 
-  let apply : item -> t -> t = function
+  let apply : item -> t -> t option = function
     | Tx_item tx -> apply_tx tx
     | Bal_assert_item ba -> apply_ba ba
-end *)
+end
+
+module Ctxd_item = struct end
 
 let make = Fn.id
diff --git a/lib/prelude.ml b/lib/prelude.ml
index 57f7af3..f571a4d 100644
--- a/lib/prelude.ml
+++ b/lib/prelude.ml
@@ -16,6 +16,29 @@ module List = struct
     go
 end
 
+module Map = struct
+  include Map
+
+  let fold_result (m : ('k, 'v, _) t) ~(init : 'acc)
+      ~(f : key:'k -> data:'v -> 'acc -> ('acc, 'err) result) :
+      ('acc, 'err) result =
+    fold_until m ~init
+      ~f:(fun ~key ~data acc ->
+        match f ~key ~data acc with
+        | Ok acc' -> Continue acc'
+        | Error _ as res -> Stop res)
+      ~finish:(fun v -> Ok v)
+
+  let fold_option (m : ('k, 'v, _) t) ~(init : 'acc)
+      ~(f : key:'k -> data:'v -> 'acc -> 'acc option) : 'acc option =
+    fold_until m ~init
+      ~f:(fun ~key ~data acc ->
+        match f ~key ~data acc with
+        | Some acc' -> Continue acc'
+        | None -> Stop None)
+      ~finish:(fun v -> Some v)
+end
+
 module Z = struct
   include Z