File: accountdbase.ml

package info (click to toggle)
misery 0.2-1.1
  • links: PTS
  • area: main
  • in suites: bullseye, buster, sid, stretch
  • size: 380 kB
  • ctags: 298
  • sloc: ml: 1,295; xml: 180; makefile: 94
file content (127 lines) | stat: -rw-r--r-- 5,003 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
(* Handling of all individual accounts within the current set of accounts. *)

open Account

module AccountsMap = Map.Make (struct type t = string let compare = compare end)

(* Map from short names to account records. *)
let dbase = ref AccountsMap.empty

(* Add an account to the database. *)
let add_account short_name acct =
  dbase := AccountsMap.add short_name acct !dbase

(* Update an account in the database. *)
let update_account = add_account

(* Look up an account by short name. *)
let lookup_account short_name context =
  try
    AccountsMap.find short_name !dbase
  with Not_found ->
    let names = AccountsMap.fold (fun short_name -> fun _ -> fun names ->
    				    names ^ "\n  " ^ short_name)
				  !dbase ""
    in
      Misc.fail ("Lookup of account `" ^ short_name ^ "' failed,\n" ^ context
                 ^ ".\n\nThe following short names are known:" ^ names ^
		 "\n\nIf the short name `" ^ short_name ^ "' is correct, add " ^
		 "a new account.")

(* Look up an account by short name, no-error version. *)
let lookup_account_nofail short_name =
  try
    Some (AccountsMap.find short_name !dbase)
  with Not_found -> None

(* Add a transaction to an account identified by a given short name. *)
let add_txn name txn context =
  let acct = Account.add_txn txn (lookup_account name context) in
    update_account name acct

(* Add a negated transaction to an account identified by a given short name. *)
let add_txn_negated name txn context =
  let acct = Account.add_txn_negated txn (lookup_account name context) in
    update_account name acct

(* Add a transaction to all accounts. *)
let add_global_txn txn =
  dbase := AccountsMap.map (Account.add_txn txn) !dbase

(* Given a predicate, a folding function and an initial value, apply
   a fold across all accounts satisfying the predicate. *)
let filter_and_fold_accounts pred fold_fn init =
  AccountsMap.fold (fun short_name ->
                    fun acct ->
                    fun current_value ->
                      if pred acct then fold_fn current_value acct
                      else current_value) !dbase init

(* Given a variable name, find those accounts defining it and return
   the total of their corresponding values, which must be integers. *)
let sum_integer_variable var =
  Misc.verbose ("Summing integer variable `" ^ var ^ "' over all accounts.");
  AccountsMap.fold (fun _ ->
                    fun acct ->
                    fun current_total ->
                      try
                        current_total +
                          (Account.lookup_integer_variable var acct)
                      with Not_found -> current_total) !dbase 0

(* Load an initial account state from a channel. *)
let load_initial_file short_name in_channel =
  add_account short_name (create_account_from_channel short_name in_channel)

(* Load initial account states from the files in the initial/ directory
   and symmetrise transactions. *)
let load_initial_files () =
  Misc.iter_files "initial" load_initial_file;
  AccountsMap.iter (
    fun short_name -> fun acct ->
      Account.iter_txns (
        fun txn ->
          if not txn.do_not_symmetrise then
	    let context = "whilst adding other halves of transactions for " ^
	    		  short_name
	    in
            let acct' = lookup_account txn.creditor context in
            let txn' = { txn with do_not_symmetrise = true;
                                  automatically_added = true;
                                  linked = false;
                                  creditor = short_name }
            in
            let f = if txn.linked then Account.add_txn
                                  else Account.add_txn_negated
            in
              update_account txn.creditor (f txn' acct')
      ) acct) !dbase

(* Lookup a creditor's or debtor's name. *)
let lookup_creditor name context =
  if name = "phantom" then "Phantom"
  else Account.full_name (lookup_account name context)

(* Iterate over all accounts. *)
let iter f = AccountsMap.iter (fun _ -> fun acct -> f acct) !dbase

(* Group accounts according to a variable's value. *)
let group var =
  Misc.verbose ("Grouping accounts according to value of var: " ^ var);
  AccountsMap.fold (fun _ ->
                    fun acct ->
                    fun current_groups ->
                      try
                        let value = Account.lookup_variable var acct in
                        Misc.verbose ("  ...adding " ^ 
                                      (Account.short_name acct) ^
                                      " (key " ^ value ^ ")");
                        let current_members =
                          (try AccountsMap.find value current_groups
                           with Not_found -> [])
                        in
                          AccountsMap.add value (acct::current_members)
                                          current_groups
                      with Not_found -> current_groups
                   ) !dbase AccountsMap.empty