summaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/account.ml210
-rw-r--r--lib/account/account.ml121
-rw-r--r--lib/account/type.ml15
-rw-r--r--lib/account/type_hierarchy.ml83
-rw-r--r--lib/account/type_hierarchy.mli15
-rw-r--r--lib/balanced_batch.ml42
-rw-r--r--lib/dune2
-rw-r--r--lib/money.ml79
8 files changed, 357 insertions, 210 deletions
diff --git a/lib/account.ml b/lib/account.ml
deleted file mode 100644
index 3a1aff0..0000000
--- a/lib/account.ml
+++ /dev/null
@@ -1,210 +0,0 @@
1open Prelude
2
3(** The 'kernel' of account types: a hierarchy of valid types. A valid type is a
4 path that leads to a node in the hierarchy. *)
5module Type_hierarchy : sig
6 type path
7 type polarity = Increase_on_debit | Increase_on_credit
8
9 val children : path -> path list
10 val sub : path -> string -> path option
11 val super : path -> path option
12 val equal_path : path -> path -> bool
13 val is_prefix : path -> prefix:path -> bool
14 val polarity : path -> polarity
15 val asset : path
16 val equity : path
17 val expense : path
18 val income : path
19 val liability : path
20end = struct
21 type polarity = Increase_on_debit | Increase_on_credit
22 type tree = { car : tree String.Map.t }
23 type trunk = { car : (polarity * tree) String.Map.t }
24 type path = Base of string | Sub of string * path
25
26 let rec path_to_list ?(suffix = []) p =
27 match p with
28 | Base x -> x :: suffix
29 | Sub (x, p') -> path_to_list ~suffix:(x :: suffix) p'
30
31 let canonical : trunk =
32 let mk alist : tree = { car = String.Map.of_alist_exn alist } in
33 {
34 car =
35 String.Map.of_alist_exn
36 [
37 ( "Asset",
38 ( Increase_on_debit,
39 mk
40 [
41 ("Accounts_receivable", mk []);
42 ("Bank", mk [ ("Savings", mk []); ("Checking", mk []) ]);
43 ("Cash", mk []);
44 ("Mutual_fund", mk []);
45 ("Stock", mk []);
46 ] ) );
47 ("Equity", (Increase_on_credit, mk []));
48 ("Expense", (Increase_on_debit, mk []));
49 ("Income", (Increase_on_credit, mk []));
50 ( "Liability",
51 ( Increase_on_credit,
52 mk [ ("Accounts_payable", mk []); ("Credit", mk []) ] ) );
53 ];
54 }
55
56 (* In this module, only the following two function entertains the
57 option that the given path may not be valid (i.e., it does not
58 throw an exception for invalid paths). *)
59 let rec get_node : path -> tree option =
60 let open Option.Let_syntax in
61 function
62 | Base x ->
63 let%map _, t = Map.find canonical.car x in
64 t
65 | Sub (t, p) ->
66 let%bind super = get_node p in
67 Map.find super.car t
68
69 (** Always gives [Some] under valid paths, giving a list of valid paths *)
70 let children (p : path) : path list =
71 let node = Option.value_exn (get_node p) in
72 List.map (Map.keys node.car) ~f:(fun sub -> Sub (sub, p))
73
74 let sub (p : path) (name : string) : path option =
75 let node = Option.value_exn (get_node p) in
76 if Map.mem node.car name then Some (Sub (name, p)) else None
77
78 let super : path -> path option = function
79 | Base _ -> None
80 | Sub (_, super) -> Some super
81
82 let rec equal_path p1 p2 =
83 match (p1, p2) with
84 | Base x1, Base x2 -> String.(x1 = x2)
85 | Sub (x1, p1'), Sub (x2, p2') -> String.(x1 = x2) && equal_path p1' p2'
86 | _, _ -> false
87
88 let is_prefix (p : path) ~(prefix : path) : bool =
89 List.is_prefix (path_to_list p) ~prefix:(path_to_list prefix)
90 ~equal:String.equal
91
92 let rec polarity = function
93 | Base x ->
94 let pol, _ = Map.find_exn canonical.car x in
95 pol
96 | Sub (_, p') -> polarity p'
97
98 let assert_valid acc =
99 match get_node acc with None -> failwith "invalid base account" | _ -> acc
100
101 let asset = Base "Asset" |> assert_valid
102 let equity = Base "Equity" |> assert_valid
103 let expense = Base "Expense" |> assert_valid
104 let income = Base "Income" |> assert_valid
105 let liability = Base "Liability" |> assert_valid
106end
107
108module Type = struct
109 type t = Type_hierarchy.path [@@deriving equal]
110
111 let rec base (t : t) : t option =
112 match Type_hierarchy.super t with
113 | None -> (* [t] is the root type *) None
114 | Some t' ->
115 (* [t] is a base type if its supertype is the root type *)
116 Some (Option.value (base t') ~default:t)
117
118 (** [a] is a strict supertype of [b] *)
119 let is_strict_super a b =
120 Type_hierarchy.is_prefix b ~prefix:a && not ([%equal: t] a b)
121end
122
123module Debit_credit = struct
124 type t = Debit | Credit [@@deriving string, sexp_of]
125
126 (* let opposite = function Debit -> Credit | Credit -> Debit *)
127end
128
129module Money = struct
130 module Amount : sig
131 type t
132
133 val equal : t -> t -> bool
134 val compare : t -> t -> int
135 val of_bigint : Bigint.t -> t option
136 val to_bigint : t -> Bigint.t
137 val ( + ) : t -> t -> t
138 val ( = ) : t -> t -> bool
139 val sexp_of_t : t -> Sexp.t
140 val zero : t
141 end = struct
142 type t = Bigint.t [@@deriving sexp_of]
143
144 let equal = Bigint.equal
145 let compare = Bigint.compare
146 let of_bigint x = if Bigint.(zero <= x) then Some x else None
147 let to_bigint x = x
148 let ( + ) x y = Bigint.(x + y)
149 let ( = ) = equal
150 let zero = Bigint.zero
151 end
152
153 module Diff : sig
154 type t
155
156 val equal : t -> t -> bool
157 val compare : t -> t -> int
158 val of_bigint : Bigint.t -> t
159 val to_bigint : t -> Bigint.t
160 val ( + ) : t -> t -> t
161 val ( +% ) : t -> Amount.t -> t
162 val ( - ) : t -> t -> t
163 val ( -% ) : t -> Amount.t -> t
164 val ( = ) : t -> t -> bool
165 val neg : t -> t
166 val ( ~$ ) : int -> t
167 val sexp_of_t : t -> Sexp.t
168
169 val of_amount :
170 Amount.t -> Debit_credit.t -> on_debit:[ `Incr | `Decr ] -> t
171 end = struct
172 type t = Bigint.t [@@deriving sexp_of]
173
174 let equal = Bigint.equal
175 let compare = Bigint.compare
176 let of_bigint x = x
177 let to_bigint x = x
178 let ( + ) x y = Bigint.(x + y)
179 let ( +% ) x y = x + of_bigint (Amount.to_bigint y)
180 let ( - ) x y = Bigint.(x - y)
181 let ( -% ) x y = x - of_bigint (Amount.to_bigint y)
182 let ( = ) = equal
183 let neg = Bigint.neg
184 let ( ~$ ) = Fn.compose of_bigint Bigint.of_int
185
186 let of_amount x (dc : Debit_credit.t) ~on_debit =
187 match (dc, on_debit) with
188 | Debit, `Incr -> of_bigint (Amount.to_bigint x)
189 | Credit, `Incr -> neg (of_bigint (Amount.to_bigint x))
190 | Debit, `Decr -> neg (of_bigint (Amount.to_bigint x))
191 | Credit, `Decr -> of_bigint (Amount.to_bigint x)
192 end
193end
194
195module Commodity_id = struct
196 type t = string [@@deriving equal, compare, sexp]
197
198 module Map = Map.Make (struct
199 type nonrec t = t [@@deriving equal, compare, sexp]
200 end)
201end
202
203module Account = struct
204 type t = Type.t * node
205
206 and node =
207 (* Balance in some commodity *)
208 | Leaf of Commodity_id.t * Money.Diff.t
209 | Subtree of node String.Map.t
210end
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 @@
1open Prelude
2
3(* TODO: Decide on public interface. Probably should not include
4 functions such as [unsafe_update_bal], but having [Balanced_batch]
5 under [Account] also feels a bit awkward. *)
6
7module Path = struct
8 type t = string list [@@deriving compare, sexp]
9end
10
11(** Ensures that only accounts with valid type hierarchies can be constructed.
12*)
13module Kernel : sig
14 type extra = { description : string }
15
16 type t = private { type_ : Type.t; extra : extra; core : core }
17
18 and core =
19 (* Balance in some commodity *)
20 | Leaf of Money.Commodity_id.t * Money.Diff.t
21 | Subtree of t String.Map.t
22
23 val make : Type.t -> extra -> core -> t option
24end = struct
25 type extra = { description : string }
26
27 type t = { type_ : Type.t; extra : extra; core : core }
28
29 and core =
30 (* Balance in some commodity *)
31 | Leaf of Money.Commodity_id.t * Money.Diff.t
32 | Subtree of t String.Map.t
33
34 let make type_ extra : core -> t option = function
35 | Leaf (comm, bal) -> Some { type_; extra; core = Leaf (comm, bal) }
36 | Subtree children ->
37 if
38 Map.for_all children ~f:(fun subacc ->
39 Type.is_super subacc.type_ ~super:type_ ~strict:false)
40 then Some { type_; extra; core = Subtree children }
41 else None
42end
43
44type t = Kernel.t
45
46type update_bal_error =
47 | Empty_path
48 | Unmatching_commodity_id of { in_account : Money.Commodity_id.t }
49 | Not_a_leaf_account
50 | Not_a_subtree_account
51 | Not_found (* TODO: report at which level *)
52
53(* We do not necessarily expect [aid] to be a valid path, as we
54 always do for paths in the type hierarchy. The difference is that
55 the type hierarchy is fixed, while the account hierarchy can
56 change over the course of a year. *)
57let rec unsafe_update_bal_aux (aid : Path.t) (dc : Money.Debit_credit.t)
58 (by_amount : Money.Amount.t) (in_comm : Money.Commodity_id.t) (w : t) :
59 (t, update_bal_error) result =
60 match (aid, w.core) with
61 | [], Leaf (comm, bal) ->
62 if [%equal: Money.Commodity_id.t] in_comm comm then (* slay! *)
63 let core' =
64 Kernel.Leaf
65 ( comm,
66 Money.Diff.(bal + of_amount by_amount dc (Type.polarity w.type_))
67 )
68 in
69 Ok (Option.value_exn (Kernel.make w.type_ w.extra core'))
70 else (* bruh *)
71 Error (Unmatching_commodity_id { in_account = comm })
72 | [], Subtree _ -> Error Not_a_leaf_account
73 | _ :: _, Leaf _ -> Error Not_a_subtree_account
74 | aid0 :: aid', Subtree subaccs -> (
75 match Map.find subaccs aid0 with
76 | None -> Error Not_found
77 | Some subacc ->
78 let open Result.Let_syntax in
79 let%bind subacc' =
80 (* TODO: when reporting at which level Not_found fails,
81 we want to make sure that we extend the information
82 in the error with the current aid0 (so we recover a
83 full path to where the account is missing *)
84 unsafe_update_bal_aux aid' dc by_amount in_comm subacc
85 in
86 let core' =
87 Kernel.Subtree (Map.set subaccs ~key:aid0 ~data:subacc')
88 in
89 Ok (Option.value_exn (Kernel.make w.type_ w.extra core')))
90
91(* Unfortunate but true, there has to be some kind of a root account
92 with no type :) *)
93type root = t String.Map.t
94
95let unsafe_update_bal (aid : Path.t) (dc : Money.Debit_credit.t)
96 (by_amount : Money.Amount.t) (in_comm : Money.Commodity_id.t) (w : root) :
97 (root, update_bal_error) result =
98 match aid with
99 | [] -> Error Empty_path
100 | aid0 :: aid' -> (
101 match Map.find w aid0 with
102 | None -> Error Not_found
103 | Some subacc ->
104 let open Result.Let_syntax in
105 (* TODO: when reporting at which level Not_found fails,
106 we want to make sure that we extend the information
107 in the error with the current aid0 (so we recover a
108 full path to where the account is missing *)
109 let%bind subacc' =
110 unsafe_update_bal_aux aid' dc by_amount in_comm subacc
111 in
112 Ok (Map.set w ~key:aid0 ~data:subacc'))
113
114module Balanced_batch_acc_paths = Balanced_batch.Make (Path)
115
116let apply_balanced_batch (b : Balanced_batch_acc_paths.t) (w : root) =
117 Map.fold_result (Balanced_batch_acc_paths.entries b) ~init:w
118 ~f:(fun ~key:aid ~(data : Balanced_batch_acc_paths.entry) w ->
119 let open Result.Let_syntax in
120 let%bind w = unsafe_update_bal aid data.dc data.amount data.commodity w in
121 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 @@
1type t = Type_hierarchy.path [@@deriving equal]
2
3let rec base (t : t) : t =
4 match Type_hierarchy.super t with
5 | None -> (* [t] is a base type *) t
6 | Some t' -> base t'
7
8(** [a] is a (strict) supertype of [b] *)
9let is_super t ~super ~strict =
10 Type_hierarchy.is_prefix super ~prefix:t
11 &&
12 (* strict → t ≠ super *)
13 ((not strict) || not ([%equal: t] t super))
14
15let 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 @@
1open Prelude
2
3type tree = { car : tree String.Map.t }
4type trunk = (Money.polarity * tree) String.Map.t
5type path = Base of string | Sub of string * path
6
7let rec path_to_list ?(suffix = []) p =
8 match p with
9 | Base x -> x :: suffix
10 | Sub (x, p') -> path_to_list ~suffix:(x :: suffix) p'
11
12let canonical : trunk =
13 let make alist : tree = { car = String.Map.of_alist_exn alist } in
14 String.Map.of_alist_exn
15 [
16 ( "Asset",
17 ( Money.Increase_on_debit,
18 make
19 [
20 ("Accounts_receivable", make []);
21 ("Bank", make [ ("Savings", make []); ("Checking", make []) ]);
22 ("Cash", make []);
23 ("Mutual_fund", make []);
24 ("Stock", make []);
25 ] ) );
26 ("Equity", (Money.Increase_on_credit, make []));
27 ("Expense", (Money.Increase_on_debit, make []));
28 ("Income", (Money.Increase_on_credit, make []));
29 ( "Liability",
30 ( Money.Increase_on_credit,
31 make [ ("Accounts_payable", make []); ("Credit", make []) ] ) );
32 ]
33
34(* In this module, only the following two function entertains the
35 option that the given path may not be valid (i.e., it does not
36 throw an exception for invalid paths). *)
37let rec get_node : path -> tree option =
38 let open Option.Let_syntax in
39 function
40 | Base x ->
41 let%map _, t = Map.find canonical x in
42 t
43 | Sub (t, p) ->
44 let%bind super = get_node p in
45 Map.find super.car t
46
47(** Always gives [Some] under valid paths, giving a list of valid paths *)
48let children (p : path) : path list =
49 let node = Option.value_exn (get_node p) in
50 List.map (Map.keys node.car) ~f:(fun sub -> Sub (sub, p))
51
52let sub (p : path) (name : string) : path option =
53 let node = Option.value_exn (get_node p) in
54 if Map.mem node.car name then Some (Sub (name, p)) else None
55
56let super : path -> path option = function
57 | Base _ -> None
58 | Sub (_, super) -> Some super
59
60let rec equal_path p1 p2 =
61 match (p1, p2) with
62 | Base x1, Base x2 -> String.(x1 = x2)
63 | Sub (x1, p1'), Sub (x2, p2') -> String.(x1 = x2) && equal_path p1' p2'
64 | _, _ -> false
65
66let is_prefix (p : path) ~(prefix : path) : bool =
67 List.is_prefix (path_to_list p) ~prefix:(path_to_list prefix)
68 ~equal:String.equal
69
70let rec polarity = function
71 | Base x ->
72 let pol, _ = Map.find_exn canonical x in
73 pol
74 | Sub (_, p') -> polarity p'
75
76let assert_valid acc =
77 match get_node acc with None -> failwith "invalid base account" | _ -> acc
78
79let asset = Base "Asset" |> assert_valid
80let equity = Base "Equity" |> assert_valid
81let expense = Base "Expense" |> assert_valid
82let income = Base "Income" |> assert_valid
83let 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 @@
1type path
2(** The 'kernel' of account types: a hierarchy of valid types. A valid type is a
3 path that leads to a node in the hierarchy. *)
4
5val children : path -> path list
6val sub : path -> string -> path option
7val super : path -> path option
8val equal_path : path -> path -> bool
9val is_prefix : path -> prefix:path -> bool
10val polarity : path -> Money.polarity
11val asset : path
12val equity : path
13val expense : path
14val income : path
15val liability : path
diff --git a/lib/balanced_batch.ml b/lib/balanced_batch.ml
new file mode 100644
index 0000000..5a64546
--- /dev/null
+++ b/lib/balanced_batch.ml
@@ -0,0 +1,42 @@
1open Prelude
2
3(* Degenerate transactions, which can be applied directly to account
4 hierarchies (because we ideally want no unsafe operations on
5 accounts) *)
6module Make (K : Map_intf.Key) : sig
7 type entry = {
8 dc : Money.Debit_credit.t;
9 commodity : Money.Commodity_id.t;
10 amount : Money.Amount.t;
11 }
12
13 type t
14 type error = Unbalanced
15
16 val make : entry Map.Make(K).t -> (t, error) result
17 val entries : t -> entry Map.Make(K).t
18end = struct
19 type entry = {
20 dc : Money.Debit_credit.t;
21 commodity : Money.Commodity_id.t;
22 amount : Money.Amount.t;
23 }
24
25 type t = entry Map.Make(K).t
26 type error = Unbalanced
27
28 let is_balanced entries =
29 Map.fold entries ~init:Money.Commodity_id.Map.empty
30 ~f:(fun ~key:_ ~data comm_balances ->
31 Map.update comm_balances data.commodity ~f:(fun ocomm_bal ->
32 let comm_bal = Option.value ocomm_bal ~default:Money.Diff.(~$0) in
33 match data.dc with
34 | Money.Debit_credit.Debit -> Money.Diff.(comm_bal +% data.amount)
35 | Money.Debit_credit.Credit -> Money.Diff.(comm_bal -% data.amount)))
36 |> Map.for_all ~f:(fun comm_bal -> Money.Diff.(comm_bal = ~$0))
37
38 let make entries =
39 if not (is_balanced entries) then Error Unbalanced else Ok entries
40
41 let entries entries = entries (* ambiguous? I disagree *)
42end
diff --git a/lib/dune b/lib/dune
index 6208dd7..ca9aac2 100644
--- a/lib/dune
+++ b/lib/dune
@@ -1,3 +1,5 @@
1(include_subdirs qualified)
2
1(library 3(library
2 (name rdcapsis) 4 (name rdcapsis)
3 (preprocess 5 (preprocess
diff --git a/lib/money.ml b/lib/money.ml
new file mode 100644
index 0000000..a06af64
--- /dev/null
+++ b/lib/money.ml
@@ -0,0 +1,79 @@
1open Prelude
2
3type polarity = Increase_on_debit | Increase_on_credit
4
5module Debit_credit = struct
6 type t = Debit | Credit [@@deriving string, sexp_of]
7
8 (* let opposite = function Debit -> Credit | Credit -> Debit *)
9end
10
11module Amount : sig
12 type t
13
14 val equal : t -> t -> bool
15 val compare : t -> t -> int
16 val of_bigint : Bigint.t -> t option
17 val to_bigint : t -> Bigint.t
18 val ( + ) : t -> t -> t
19 val ( = ) : t -> t -> bool
20 val sexp_of_t : t -> Sexp.t
21 val zero : t
22end = struct
23 type t = Bigint.t [@@deriving sexp_of]
24
25 let equal = Bigint.equal
26 let compare = Bigint.compare
27 let of_bigint x = if Bigint.(zero <= x) then Some x else None
28 let to_bigint x = x
29 let ( + ) x y = Bigint.(x + y)
30 let ( = ) = equal
31 let zero = Bigint.zero
32end
33
34module Diff : sig
35 type t
36
37 val equal : t -> t -> bool
38 val compare : t -> t -> int
39 val of_bigint : Bigint.t -> t
40 val to_bigint : t -> Bigint.t
41 val ( + ) : t -> t -> t
42 val ( +% ) : t -> Amount.t -> t
43 val ( - ) : t -> t -> t
44 val ( -% ) : t -> Amount.t -> t
45 val ( = ) : t -> t -> bool
46 val neg : t -> t
47 val ( ~$ ) : int -> t
48 val sexp_of_t : t -> Sexp.t
49 val of_amount : Amount.t -> Debit_credit.t -> polarity -> t
50end = struct
51 type t = Bigint.t [@@deriving sexp_of]
52
53 let equal = Bigint.equal
54 let compare = Bigint.compare
55 let of_bigint x = x
56 let to_bigint x = x
57 let ( + ) x y = Bigint.(x + y)
58 let ( +% ) x y = x + of_bigint (Amount.to_bigint y)
59 let ( - ) x y = Bigint.(x - y)
60 let ( -% ) x y = x - of_bigint (Amount.to_bigint y)
61 let ( = ) = equal
62 let neg = Bigint.neg
63 let ( ~$ ) = Fn.compose of_bigint Bigint.of_int
64
65 let of_amount x (dc : Debit_credit.t) (on_debit : polarity) =
66 match (dc, on_debit) with
67 | Debit, Increase_on_debit -> of_bigint (Amount.to_bigint x)
68 | Credit, Increase_on_debit -> neg (of_bigint (Amount.to_bigint x))
69 | Credit, Increase_on_credit -> of_bigint (Amount.to_bigint x)
70 | Debit, Increase_on_credit -> neg (of_bigint (Amount.to_bigint x))
71end
72
73module Commodity_id = struct
74 type t = string [@@deriving equal, compare, sexp]
75
76 module Map = Map.Make (struct
77 type nonrec t = t [@@deriving equal, compare, sexp]
78 end)
79end
generated by cgit v1.3 (git 2.53.0) at 2026-04-16 07:04:09 +0000