summaryrefslogtreecommitdiffstats
path: root/lib/account.ml
diff options
context:
space:
mode:
Diffstat (limited to 'lib/account.ml')
-rw-r--r--lib/account.ml210
1 files changed, 0 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
generated by cgit v1.3 (git 2.53.0) at 2026-04-16 07:12:26 +0000