Command-line and Emacs Calendar Client
ryan.freumh.org
1open Result
2
3let default_timezone =
4 ref (fun () ->
5 match Timedesc.Time_zone.local () with
6 | Some tz -> tz
7 | None -> Timedesc.Time_zone.utc)
8
9let timedesc_to_ptime dt =
10 match
11 Timedesc.to_timestamp_single dt |> Timedesc.Utils.ptime_of_timestamp
12 with
13 | Some t -> t
14 | None -> failwith "Invalid date conversion from Timedesc to Ptime"
15
16let ptime_to_timedesc ?(tz = !default_timezone ()) ptime =
17 let ts = Timedesc.Utils.timestamp_of_ptime ptime in
18 match Timedesc.of_timestamp ~tz_of_date_time:tz ts with
19 | Some dt -> dt
20 | None -> failwith "Invalid date conversion from Ptime to Timedesc"
21
22let get_today =
23 ref (fun ?(tz = !default_timezone ()) () ->
24 let now = Timedesc.now ~tz_of_date_time:tz () in
25 let date = Timedesc.date now in
26 let midnight = Timedesc.Time.make_exn ~hour:0 ~minute:0 ~second:0 () in
27 let dt = Timedesc.of_date_and_time_exn ~tz date midnight in
28 timedesc_to_ptime dt)
29
30(* Convert a midnight timestamp to end-of-day (23:59:59) *)
31let to_end_of_day date =
32 let dt = ptime_to_timedesc date in
33 let date = Timedesc.date dt in
34 let end_of_day_time =
35 Timedesc.Time.make_exn ~hour:23 ~minute:59 ~second:59 ()
36 in
37 let end_of_day = Timedesc.of_date_and_time_exn date end_of_day_time in
38 timedesc_to_ptime end_of_day
39
40let add_days date days =
41 let dt = ptime_to_timedesc date in
42 let date = Timedesc.date dt in
43 let new_date = Timedesc.Date.add ~days date in
44 let time = Timedesc.time dt in
45 let new_dt = Timedesc.of_date_and_time_exn new_date time in
46 timedesc_to_ptime new_dt
47
48let add_weeks date weeks = add_days date (weeks * 7)
49
50let add_months date months =
51 let dt = ptime_to_timedesc date in
52 let old_ym = Timedesc.ym dt in
53 let year = Timedesc.Ym.year old_ym in
54 let month = Timedesc.Ym.month old_ym in
55 let day = Timedesc.day dt in
56
57 (* Calculate new year and month *)
58 let total_month = (year * 12) + month - 1 + months in
59 let new_year = total_month / 12 in
60 let new_month = (total_month mod 12) + 1 in
61
62 (* Try to create new date, handling end of month cases properly *)
63 let rec adjust_day d =
64 match Timedesc.Date.Ymd.make ~year:new_year ~month:new_month ~day:d with
65 | Ok new_date ->
66 let time = Timedesc.time dt in
67 let new_dt = Timedesc.of_date_and_time_exn new_date time in
68 timedesc_to_ptime new_dt
69 | Error _ ->
70 if d > 1 then adjust_day (d - 1)
71 else failwith "Invalid date after adding months"
72 in
73 adjust_day day
74
75let add_years date years = add_months date (years * 12)
76
77let get_start_of_week date =
78 let dt = ptime_to_timedesc date in
79 let day_of_week = Timedesc.weekday dt in
80 let days_to_subtract =
81 match day_of_week with
82 | `Mon -> 0
83 | `Tue -> 1
84 | `Wed -> 2
85 | `Thu -> 3
86 | `Fri -> 4
87 | `Sat -> 5
88 | `Sun -> 6
89 in
90 let monday_date =
91 Timedesc.Date.sub ~days:days_to_subtract (Timedesc.date dt)
92 in
93 let midnight = Timedesc.Time.make_exn ~hour:0 ~minute:0 ~second:0 () in
94 let monday_with_midnight =
95 Timedesc.of_date_and_time_exn monday_date midnight
96 in
97 timedesc_to_ptime monday_with_midnight
98
99let get_start_of_current_week ?(tz = !default_timezone ()) () =
100 get_start_of_week (!get_today ~tz ())
101
102let get_start_of_next_week ?(tz = !default_timezone ()) () =
103 add_days (get_start_of_current_week ~tz ()) 7
104
105let get_end_of_week date = add_days (get_start_of_week date) 6
106
107let get_end_of_current_week ?(tz = !default_timezone ()) () =
108 get_end_of_week (!get_today ~tz ())
109
110let get_end_of_next_week ?(tz = !default_timezone ()) () =
111 get_end_of_week (get_start_of_next_week ~tz ())
112
113let get_start_of_month date =
114 let dt = ptime_to_timedesc date in
115 let year = Timedesc.year dt in
116 let month = Timedesc.month dt in
117
118 (* Create a date for the first of the month *)
119 match Timedesc.Date.Ymd.make ~year ~month ~day:1 with
120 | Ok first_day ->
121 let midnight = Timedesc.Time.make_exn ~hour:0 ~minute:0 ~second:0 () in
122 let first_of_month = Timedesc.of_date_and_time_exn first_day midnight in
123 timedesc_to_ptime first_of_month
124 | Error _ -> failwith "Invalid date for start of month"
125
126let get_start_of_current_month ?(tz = !default_timezone ()) () =
127 get_start_of_month (!get_today ~tz ())
128
129let get_start_of_next_month ?(tz = !default_timezone ()) () =
130 add_months (get_start_of_current_month ~tz ()) 1
131
132let get_end_of_month date =
133 let dt = ptime_to_timedesc date in
134 let year = Timedesc.year dt in
135 let month = Timedesc.month dt in
136
137 (* Determine next month and year *)
138 let next_month_int = if month == 12 then 1 else month + 1 in
139 let next_month_year = if month == 12 then year + 1 else year in
140
141 (* Create a date for the first of next month *)
142 match
143 Timedesc.Date.Ymd.make ~year:next_month_year ~month:next_month_int ~day:1
144 with
145 | Ok first_of_next_month -> (
146 (* Create the timestamp and subtract 1 second *)
147 let midnight = Timedesc.Time.make_exn ~hour:0 ~minute:0 ~second:0 () in
148 let first_of_next_month_dt =
149 Timedesc.of_date_and_time_exn first_of_next_month midnight
150 in
151 let one_second = Timedesc.Span.For_human.make_exn ~seconds:1 () in
152 let end_of_month_ts =
153 match Timedesc.to_timestamp first_of_next_month_dt with
154 | `Single ts -> Timedesc.Span.sub ts one_second
155 | `Ambiguous (ts, _) -> Timedesc.Span.sub ts one_second
156 in
157 match Timedesc.of_timestamp end_of_month_ts with
158 | Some end_of_month -> timedesc_to_ptime end_of_month
159 | None -> failwith "Invalid timestamp for end of month")
160 | Error _ -> failwith "Invalid date for end of month"
161
162let get_end_of_current_month ?(tz = !default_timezone ()) () =
163 get_end_of_month (!get_today ~tz ())
164
165let get_end_of_next_month ?(tz = !default_timezone ()) () =
166 get_end_of_month (get_start_of_next_month ~tz ())
167
168let get_start_of_year date =
169 let dt = ptime_to_timedesc date in
170 let year = Timedesc.year dt in
171
172 (* Create a date for the first of January *)
173 match Timedesc.Date.Ymd.make ~year ~month:1 ~day:1 with
174 | Ok first_day ->
175 let midnight = Timedesc.Time.make_exn ~hour:0 ~minute:0 ~second:0 () in
176 let first_of_year = Timedesc.of_date_and_time_exn first_day midnight in
177 timedesc_to_ptime first_of_year
178 | Error _ -> failwith "Invalid date for start of year"
179
180let get_start_of_current_year ?(tz = !default_timezone ()) () =
181 get_start_of_year (!get_today ~tz ())
182
183let get_start_of_next_year ?(tz = !default_timezone ()) () =
184 add_years (get_start_of_current_year ~tz ()) 1
185
186let get_end_of_year date =
187 let dt = ptime_to_timedesc date in
188 let year = Timedesc.year dt in
189
190 (* Create a date for the last day of the year (December 31) *)
191 match Timedesc.Date.Ymd.make ~year ~month:12 ~day:31 with
192 | Ok last_day ->
193 let end_of_day =
194 Timedesc.Time.make_exn ~hour:23 ~minute:59 ~second:59 ()
195 in
196 let end_of_year = Timedesc.of_date_and_time_exn last_day end_of_day in
197 timedesc_to_ptime end_of_year
198 | Error _ -> failwith "Invalid date for end of year"
199
200let get_end_of_current_year ?(tz = !default_timezone ()) () =
201 get_end_of_year (!get_today ~tz ())
202
203let get_end_of_next_year ?(tz = !default_timezone ()) () =
204 get_end_of_year (get_start_of_next_year ~tz ())
205
206let convert_relative_date_formats ?(tz = !default_timezone ()) ~today ~tomorrow
207 ~week ~month () =
208 if today then
209 let today_date = !get_today ~tz () in
210 (* Set the end date to end-of-day to include all events on that day *)
211 let end_of_today = to_end_of_day today_date in
212 Some (today_date, end_of_today)
213 else if tomorrow then
214 let today = !get_today ~tz () in
215 let tomorrow_date = add_days today 1 in
216 (* Set the end date to end-of-day to include all events on that day *)
217 let end_of_tomorrow = to_end_of_day tomorrow_date in
218 Some (tomorrow_date, end_of_tomorrow)
219 else if week then
220 let week_start = get_start_of_current_week ~tz () in
221 let week_end_date = add_days week_start 6 in
222 (* Sunday is 6 days from Monday *)
223 (* Set the end date to end-of-day to include all events on Sunday *)
224 let end_of_week = to_end_of_day week_end_date in
225 Some (week_start, end_of_week)
226 else if month then
227 let month_start = get_start_of_current_month ~tz () in
228 let month_end = get_end_of_month month_start in
229 Some (month_start, month_end)
230 else None
231
232let ( let* ) = Result.bind
233
234let parse_full_iso_datet ~tz expr =
235 let regex = Re.Pcre.regexp "^(\\d{4})-(\\d{1,2})-(\\d{1,2})$" in
236 if Re.Pcre.pmatch ~rex:regex expr then
237 let match_result = Re.Pcre.exec ~rex:regex expr in
238 let year = int_of_string (Re.Pcre.get_substring match_result 1) in
239 let month = int_of_string (Re.Pcre.get_substring match_result 2) in
240 let day = int_of_string (Re.Pcre.get_substring match_result 3) in
241 match Timedesc.Date.Ymd.make ~year ~month ~day with
242 | Ok date ->
243 let midnight = Timedesc.Time.make_exn ~hour:0 ~minute:0 ~second:0 () in
244 let dt = Timedesc.of_date_and_time_exn ~tz date midnight in
245 Some (Ok (timedesc_to_ptime dt))
246 | Error _ -> Some (Error (`Msg (Printf.sprintf "Invalid date: %s" expr)))
247 else None
248
249let parse_year_only ~tz expr parameter =
250 let regex = Re.Pcre.regexp "^(\\d{4})$" in
251 if Re.Pcre.pmatch ~rex:regex expr then
252 let match_result = Re.Pcre.exec ~rex:regex expr in
253 let year = int_of_string (Re.Pcre.get_substring match_result 1) in
254 match parameter with
255 | `From -> (
256 match Timedesc.Date.Ymd.make ~year ~month:1 ~day:1 with
257 | Ok date ->
258 let time = Timedesc.Time.make_exn ~hour:0 ~minute:0 ~second:0 () in
259 let dt = Timedesc.of_date_and_time_exn ~tz date time in
260 Some (Ok (timedesc_to_ptime dt))
261 | Error _ ->
262 Some (Error (`Msg (Printf.sprintf "Invalid year: %s" expr))))
263 | `To -> (
264 match Timedesc.Date.Ymd.make ~year ~month:12 ~day:31 with
265 | Ok date ->
266 let time =
267 Timedesc.Time.make_exn ~hour:23 ~minute:59 ~second:59 ()
268 in
269 let dt = Timedesc.of_date_and_time_exn ~tz date time in
270 Some (Ok (timedesc_to_ptime dt))
271 | Error _ ->
272 Some (Error (`Msg (Printf.sprintf "Invalid year: %s" expr))))
273 else None
274
275let parse_year_month ~tz expr parameter =
276 let regex = Re.Pcre.regexp "^(\\d{4})-(\\d{1,2})$" in
277 if Re.Pcre.pmatch ~rex:regex expr then
278 let match_result = Re.Pcre.exec ~rex:regex expr in
279 let year = int_of_string (Re.Pcre.get_substring match_result 1) in
280 let month = int_of_string (Re.Pcre.get_substring match_result 2) in
281 match parameter with
282 | `From -> (
283 match Timedesc.Date.Ymd.make ~year ~month ~day:1 with
284 | Ok date ->
285 let time = Timedesc.Time.make_exn ~hour:0 ~minute:0 ~second:0 () in
286 let dt = Timedesc.of_date_and_time_exn ~tz date time in
287 Some (Ok (timedesc_to_ptime dt))
288 | Error _ ->
289 Some (Error (`Msg (Printf.sprintf "Invalid year-month: %s" expr))))
290 | `To -> (
291 let next_month = if month = 12 then 1 else month + 1 in
292 let next_month_year = if month = 12 then year + 1 else year in
293 match
294 Timedesc.Date.Ymd.make ~year:next_month_year ~month:next_month ~day:1
295 with
296 | Ok next_month_date ->
297 let last_day_of_month = Timedesc.Date.sub ~days:1 next_month_date in
298 let end_of_day =
299 Timedesc.Time.make_exn ~hour:23 ~minute:59 ~second:59 ()
300 in
301 let dt =
302 Timedesc.of_date_and_time_exn ~tz last_day_of_month end_of_day
303 in
304 Some (Ok (timedesc_to_ptime dt))
305 | Error _ ->
306 Some (Error (`Msg (Printf.sprintf "Invalid year-month: %s" expr))))
307 else None
308
309let parse_relative ~tz expr parameter =
310 let regex = Re.Pcre.regexp "^([+-])(\\d+)([dwmy])$" in
311 if Re.Pcre.pmatch ~rex:regex expr then
312 let match_result = Re.Pcre.exec ~rex:regex expr in
313 let sign = Re.Pcre.get_substring match_result 1 in
314 let num = int_of_string (Re.Pcre.get_substring match_result 2) in
315 let unit = Re.Pcre.get_substring match_result 3 in
316 let multiplier = if sign = "+" then 1 else -1 in
317 let value = num * multiplier in
318 let today = !get_today ~tz () in
319 match unit with
320 | "d" -> Some (Ok (add_days today value))
321 | "w" -> (
322 let date = add_weeks today value in
323 match parameter with
324 | `From -> Some (Ok (get_start_of_week date))
325 | `To -> Some (Ok (get_end_of_week date)))
326 | "m" -> (
327 let date = add_months today value in
328 match parameter with
329 | `From -> Some (Ok (get_start_of_month date))
330 | `To -> Some (Ok (get_end_of_month date)))
331 | "y" -> (
332 let date = add_years today value in
333 match parameter with
334 | `From -> Some (Ok (get_start_of_year date))
335 | `To -> Some (Ok (get_end_of_year date)))
336 | _ -> Some (Error (`Msg (Printf.sprintf "Invalid date unit: %s" unit)))
337 else None
338
339let parse_date ?(tz = !default_timezone ()) expr parameter =
340 match expr with
341 | "today" -> Ok (!get_today ~tz ())
342 | "tomorrow" -> Ok (add_days (!get_today ~tz ()) 1)
343 | "yesterday" -> Ok (add_days (!get_today ~tz ()) (-1))
344 | "this-week" -> (
345 match parameter with
346 | `From -> Ok (get_start_of_current_week ~tz ())
347 | `To -> Ok (get_end_of_current_week ~tz ()))
348 | "next-week" -> (
349 match parameter with
350 | `From -> Ok (get_start_of_next_week ~tz ())
351 | `To -> Ok (get_end_of_next_week ~tz ()))
352 | "this-month" -> (
353 match parameter with
354 | `From -> Ok (get_start_of_current_month ~tz ())
355 | `To -> Ok (get_end_of_current_month ~tz ()))
356 | "next-month" -> (
357 match parameter with
358 | `From -> Ok (get_start_of_next_month ~tz ())
359 | `To -> Ok (get_end_of_next_month ~tz ()))
360 | _ -> (
361 (* Option alternative operator *)
362 let ( |>? ) opt f = match opt with None -> f () | Some x -> Some x in
363 ( ( ( parse_full_iso_datet ~tz expr |>? fun () ->
364 parse_year_only ~tz expr parameter )
365 |>? fun () -> parse_year_month ~tz expr parameter )
366 |>? fun () -> parse_relative ~tz expr parameter )
367 |> function
368 | Some result -> result
369 | None -> Error (`Msg (Printf.sprintf "Invalid date format: %s" expr)))
370
371let parse_time str =
372 try
373 let regex =
374 Re.Perl.compile_pat "^([0-9]{1,2}):([0-9]{1,2})(?::([0-9]{1,2}))?$"
375 in
376 match Re.exec_opt regex str with
377 | Some groups ->
378 let hour = int_of_string (Re.Group.get groups 1) in
379 let minute = int_of_string (Re.Group.get groups 2) in
380 let second =
381 try int_of_string (Re.Group.get groups 3) with Not_found -> 0
382 in
383 if hour < 0 || hour > 23 then
384 Error (`Msg (Printf.sprintf "Invalid hour: %d" hour))
385 else if minute < 0 || minute > 59 then
386 Error (`Msg (Printf.sprintf "Invalid minute: %d" minute))
387 else if second < 0 || second > 59 then
388 Error (`Msg (Printf.sprintf "Invalid second: %d" second))
389 else Ok (hour, minute, second)
390 | None -> Error (`Msg "Invalid time format. Expected HH:MM or HH:MM:SS")
391 with e ->
392 Error
393 (`Msg (Printf.sprintf "Error parsing time: %s" (Printexc.to_string e)))
394
395let parse_date_time ?(tz = !default_timezone ()) ~date ~time parameter =
396 let* date_ptime = parse_date date parameter ~tz in
397 let* h, min, s = parse_time time in
398
399 let dt = ptime_to_timedesc ~tz date_ptime in
400 let date_part = Timedesc.date dt in
401
402 (* Create time *)
403 match Timedesc.Time.make ~hour:h ~minute:min ~second:s () with
404 | Ok time_part -> (
405 (* Combine date and time *)
406 match Timedesc.of_date_and_time ~tz date_part time_part with
407 | Ok combined -> Ok (timedesc_to_ptime combined)
408 | Error _ -> Error (`Msg "Invalid date-time combination"))
409 | Error _ -> Error (`Msg "Invalid time for date-time combination")
410
411let ptime_of_ical = function
412 | `Datetime (`Utc t) -> t
413 | `Datetime (`Local t) ->
414 let tz = Timedesc.Time_zone.local_exn () in
415 let ts = Timedesc.Utils.timestamp_of_ptime t in
416 (* Icalendar gives us the Ptime in UTC, which we parse to a Timedesc *)
417 let dt =
418 Timedesc.of_timestamp_exn ~tz_of_date_time:Timedesc.Time_zone.utc ts
419 in
420 (* We extract the datetime, and reinterpret it in the appropriate timezone *)
421 let date = Timedesc.date dt in
422 let time = Timedesc.time dt in
423 let dt = Timedesc.of_date_and_time_exn ~tz date time in
424 timedesc_to_ptime dt
425 | `Datetime (`With_tzid (t, (_, tzid))) ->
426 let tz =
427 match Timedesc.Time_zone.make tzid with
428 | Some tz -> tz
429 | None -> failwith (Printf.sprintf "Warning: Unknown timezone %s" tzid)
430 in
431 (* Icalendar gives us the Ptime in UTC, which we parse to a Timedesc *)
432 let ts = Timedesc.Utils.timestamp_of_ptime t in
433 let dt =
434 Timedesc.of_timestamp_exn ~tz_of_date_time:Timedesc.Time_zone.utc ts
435 in
436 (* We extract the datetime, and reinterpret it in the appropriate timezone *)
437 let date = Timedesc.date dt in
438 let time = Timedesc.time dt in
439 let dt = Timedesc.of_date_and_time_exn ~tz date time in
440 timedesc_to_ptime dt
441 | `Date date -> (
442 let y, m, d = date in
443 match Timedesc.Date.Ymd.make ~year:y ~month:m ~day:d with
444 | Ok new_date ->
445 let midnight =
446 Timedesc.Time.make_exn ~hour:0 ~minute:0 ~second:0 ()
447 in
448 let new_dt = Timedesc.of_date_and_time_exn new_date midnight in
449 timedesc_to_ptime new_dt
450 | Error _ -> failwith (Printf.sprintf "Invalid date %d-%d-%d" y m d))