File: meets.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 (350 lines) | stat: -rw-r--r-- 12,786 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
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
(* Handling of automatic entries for Club meets. *)

open Account

let meets_pool_short_name = "meets-pool"
let lights_pool_short_name = "lamps-pool"
let gear_pool_short_name = "personal-gear-pool"
let srt_kit_pool_short_name = "srt-pool"

type meet_params = { driver_fee : Sumofmoney.amount;
		     non_driver_fee : Sumofmoney.amount;
		     light_fee : Sumofmoney.amount;
		     gear_fee : Sumofmoney.amount;
		     srt_fee : Sumofmoney.amount;
		     breakfast_fee : Sumofmoney.amount;
		     dinner_fee : Sumofmoney.amount }

type meet_state = { driver : bool;
		    fuel : Sumofmoney.amount;
		    food : Sumofmoney.amount;
		    breakfasts : int;
		    dinners : int;
		    light : int;
		    gear : int;
		    srt : int;
                    special_meet_fee : Sumofmoney.amount option }

let find_variable context name vars =
  try
    List.assoc name vars
  with Not_found ->
    Misc.fail ("Variable `" ^ name ^ "' not found " ^ context)

let first_word line =
  if line = "" then raise Not_found
  else
    try
      let index = String.index line ' ' in
        (String.sub line 0 index,
         String.sub line (index + 1) ((String.length line) - index - 1))
    with Not_found -> (line, "")

let first_word_required line msg context =
  try
    first_word line
  with Not_found ->
    Misc.fail (msg ^ " at this point:\n" ^ line ^ "\n" ^ context)

let first_word_required_money line msg context =
  let word, rest = first_word_required line msg context in
    (Units.convert word context, rest)

let first_word_required_int line msg context =
  let word, rest = first_word_required line msg context in
    (int_of_string word, rest)

let rec iter_n n f =
  if n = 0 then ()
  else (f (); iter_n (n - 1) f)

let enter_txn short_name name day month year caver params state =
  let context = "whilst entering transactions for meet " ^ short_name in
  let fee_desc = " for " ^ name in
  let meet_fee = { year = year;
  		   month = month;
		   day = day;
		   creditor = caver;
		   amount = (match state.special_meet_fee with
                               None ->
                                 if state.driver then params.driver_fee
		   	         else params.non_driver_fee
                             | Some fee -> fee);
		   description = (if state.driver
		                  then "Driver's meet fee" ^ fee_desc
		   	          else "Meet fee" ^ fee_desc);
		   automatically_added = true;
		   do_not_symmetrise = true;
                   linked = false }
  in
  let fuel = { year = year;
  	       month = month;
	       day = day;
	       creditor = caver;
	       amount = state.fuel;
	       description = "Fuel for " ^ name;
	       automatically_added = true;
               linked = false;
	       do_not_symmetrise = true }
  in
  let food = { year = year;
  	       month = month;
	       day = day;
	       creditor = caver;
	       amount = state.food;
	       description = "Food shopping for " ^ name;
	       automatically_added = true;
               linked = false;
	       do_not_symmetrise = true }
  in
  let breakfast = { year = year;
  	            month = month;
	            day = day;
	            creditor = meets_pool_short_name;
	            amount = Sumofmoney.negate params.breakfast_fee;
	            description = "One breakfast on " ^ name;
	            automatically_added = true;
                    linked = false;
	            do_not_symmetrise = true }
  in
  let dinner = { year = year;
  	         month = month;
	         day = day;
	         creditor = meets_pool_short_name;
	         amount = Sumofmoney.negate params.dinner_fee;
	         description = "One dinner on " ^ name;
	         automatically_added = true;
                 linked = false;
	         do_not_symmetrise = true }
  in
  let light = { year = year;
  	        month = month;
	        day = day;
	        creditor = lights_pool_short_name;
	        amount = Sumofmoney.negate params.light_fee;
	        description = "One day's light hire on " ^ name;
	        automatically_added = true;
                linked = false;
	        do_not_symmetrise = true }
  in
  let gear = { year = year;
  	       month = month;
	       day = day;
	       creditor = gear_pool_short_name;
	       amount = Sumofmoney.negate params.gear_fee;
	       description = "One day's personal gear hire on " ^ name;
	       automatically_added = true;
               linked = false;
	       do_not_symmetrise = true }
  in
  let srt = { year = year;
  	       month = month;
	       day = day;
	       creditor = srt_kit_pool_short_name;
	       amount = Sumofmoney.negate params.srt_fee;
	       description = "One day's SRT kit hire on " ^ name;
	       automatically_added = true;
               linked = false;
	       do_not_symmetrise = true }
  in
    (* The caver's meet fee, credited to the account for the meet. *)
    Accountdbase.add_txn short_name meet_fee context;
    (* The caver's meet fee, debited from the caver's account. *)
    Accountdbase.add_txn_negated
      caver { meet_fee with creditor = meets_pool_short_name } context;
    (* The caver's meet fee, credited to the meets pool. *)
    Accountdbase.add_txn meets_pool_short_name meet_fee context;
    (if not (Sumofmoney.is_zero state.fuel) then
     begin
       (* Any fuel expenditure by the caver, credited to their account. *)
       Accountdbase.add_txn
         caver { fuel with creditor = meets_pool_short_name } context;
       (* Any fuel expenditure by the caver, debited from the meets pool. *)
       Accountdbase.add_txn_negated meets_pool_short_name fuel context;
       (* Any fuel expenditure by the caver, debited from the account
          for the meet. *)
       Accountdbase.add_txn_negated short_name fuel context
     end);
    (if not (Sumofmoney.is_zero state.food) then
     begin
       (* Any food expenditure by the caver, credited to their account. *)
       Accountdbase.add_txn
         caver { food with creditor = meets_pool_short_name } context;
       (* Any food expenditure by the caver, debited from the meets pool. *)
       Accountdbase.add_txn_negated meets_pool_short_name food context;
       (* Any food expenditure by the caver, debited from the account
          for the meet. *)
       Accountdbase.add_txn_negated short_name food context
     end);
    (* Breakfasts. *)
    iter_n state.breakfasts
      (fun () -> Accountdbase.add_txn caver breakfast context;
      		 Accountdbase.add_txn_negated meets_pool_short_name
		   { breakfast with creditor = caver } context;
		 Accountdbase.add_txn_negated short_name
		   { breakfast with creditor = caver } context);
    (* Dinners. *)
    iter_n state.dinners
      (fun () -> Accountdbase.add_txn caver dinner context;
      		 Accountdbase.add_txn_negated meets_pool_short_name
		   { dinner with creditor = caver } context;
		 Accountdbase.add_txn_negated short_name
		   { dinner with creditor = caver } context);
    (* Lights. *)
    iter_n state.light
      (fun () -> Accountdbase.add_txn caver light context;
      		 Accountdbase.add_txn_negated lights_pool_short_name
		   { light with creditor = caver } context);
    (* Personal gear sets. *)
    iter_n state.gear
      (fun () -> Accountdbase.add_txn caver gear context;
      		 Accountdbase.add_txn_negated gear_pool_short_name
		   { gear with creditor = caver } context);
    (* SRT kits. *)
    iter_n state.srt
      (fun () -> Accountdbase.add_txn caver srt context;
      		 Accountdbase.add_txn_negated srt_kit_pool_short_name
		   { srt with creditor = caver } context)

let date_rexp = Str.regexp "^\\(20[0-1][0-9]\\)-\\([0-9][0-9]\\)-\\([0-9][0-9]\\)"

let parse_date str context =
  if Str.string_match date_rexp str 0 then
    (int_of_string (Str.matched_group 1 str),
     int_of_string (Str.matched_group 2 str),
     int_of_string (Str.matched_group 3 str))
  else Misc.fail ("Bad date " ^ str ^ " (must be YYYY-MM-DD)\n" ^ context)

let load_meet_file params short_name channel =
  Misc.verbose ("Reading meet file: " ^ short_name);
  let context = "whilst reading meet file: " ^ short_name in
  let vars = Variables.read_variables channel in
  let meet_name = find_variable context "name" vars in
  let existing_acct = Accountdbase.lookup_account_nofail short_name in
  let meet_acct =
    if existing_acct = None then
      Account.create short_name meet_name [("group", "Meets")]
    else
      let meets_pool = Accountdbase.lookup_account "meets-pool"
      		         "this account must be present for correct operation"
      in
      let existing_acct' =
        match existing_acct with None -> assert false | Some x -> x
      in
      let prefix = "" in
        Accountdbase.update_account "meets-pool"
	                            (Account.copy existing_acct' meets_pool
				    		  prefix);
	existing_acct'
  in
  let _ = Accountdbase.add_account short_name meet_acct in
  let meet_date = find_variable context "date" vars in
  let year, month, day = parse_date meet_date context in
  let rec read_line () =
    try
      let line = input_line channel in
      if line = "" || String.sub line 0 1 = "#" then
        read_line ()
      else
      let caver, rest = first_word_required line "Short name expected" context
      in
      let rec read_modifiers chars state =
        try
          let word, rest = first_word chars in
	  let context = "whilst reading line:\n" ^ line in
	    match word with
	      "driver" -> read_modifiers rest { state with driver = true }
	    | "non-driver" -> read_modifiers rest { state with driver = false }
	    | "special-meet-fee" ->
	      let fee, rest =
	        first_word_required_money rest "Meet fee expected" context
	      in
	        read_modifiers rest { state with special_meet_fee = Some fee }
	    | "fuel" ->
	      let fuel, rest =
	        first_word_required_money rest "Fuel amount expected" context
	      in
	        read_modifiers rest { state with fuel = fuel }
	    | "food" ->
	      let food, rest =
	        first_word_required_money rest "Food amount expected" context
	      in
	        read_modifiers rest { state with food = food }
	    | "breakfast" ->
	      let breakfasts, rest =
	        first_word_required_int rest "Number of breakfasts expected"
					context
	      in
	        read_modifiers rest { state with breakfasts = breakfasts }
	    | "dinner" ->
	      let dinners, rest =
	        first_word_required_int rest "Number of dinners expected"
					context
	      in
	        read_modifiers rest { state with dinners = dinners }
	    | "light" ->
	      let light, rest =
	        first_word_required_int rest
		                        "Number of days of light use expected"
					context
	      in
	        read_modifiers rest { state with light = light }
	    | "srt" ->
	      let srt, rest =
	        first_word_required_int rest
		                        "Number of days of SRT use expected"
					context
	      in
	        read_modifiers rest { state with srt = srt }
	    | "gear" ->
	      let gear, rest =
	        first_word_required_int rest
		                        "Number of days of gear use expected"
					context
	      in
	        read_modifiers rest { state with gear = gear }
	    | _ -> Misc.fail ("Don't understand first word of: " ^ chars ^
	                      "\n" ^ context)
	with Not_found ->
	begin
	  enter_txn short_name meet_name day month year caver params state;
          read_line ()
	end
      in
        read_modifiers rest { driver = false;
			      fuel = Sumofmoney.zero;
			      food = Sumofmoney.zero;
			      breakfasts = 2;
			      dinners = 1;
			      light = 0;
			      gear = 0;
			      srt = 0;
                              special_meet_fee = None }
    with End_of_file -> ()
  in
    read_line ()

let find_variable_money context name vars =
  Units.convert (find_variable context name vars) context

let process () =
  Misc.verbose "Reading meets config file.";
  try
    let channel = Misc.open_config_file_fail_ok "meets" in
    let vars = Variables.read_variables channel in
    let context = "whilst reading meets config file" in
    let params = { driver_fee = find_variable_money context "driver_fee" vars;
    		   non_driver_fee = find_variable_money context
  		 				        "non_driver_fee" vars;
  		   light_fee = find_variable_money context "light" vars;
  		   gear_fee = find_variable_money context "gear" vars;
  		   srt_fee = find_variable_money context "srt" vars;
  		   breakfast_fee = find_variable_money context "breakfast" vars;
  		   dinner_fee = find_variable_money context "dinner" vars }
    in
      close_in channel;
      Misc.verbose "Processing meets.";
      Misc.iter_files "meets" (load_meet_file params);
      Misc.verbose "Processing meets done."
  with Not_found -> Misc.verbose "No meets config file found; skipping."