Paolo Donadeo
122a65f3e0
Remove debug logging from `collect_triggers` and `separate_master_and_recurrence`, and add full alarm rendering support: convert `Timedesc.Span.t` triggers to `++n`/`WARN`/`+n`/`SCHED` remind syntax for both all-day and timed events, with dynamic `FSET` generation for multiple triggers and annotated `MSG` bodies showing advance notice.
440 lines
17 KiB
OCaml
440 lines
17 KiB
OCaml
open Utils
|
|
|
|
type week_first_day = [ `Sunday | `Monday ]
|
|
|
|
type simple_weekly = {
|
|
count_or_until : Icalendar.count_or_until option;
|
|
interval : int option; (** Optional interval for weekly recurrence, default is 1 *)
|
|
byday : Icalendar.weekday list;
|
|
week_start : week_first_day option; (** First day of the week for weekly recurrence *)
|
|
}
|
|
(** A simple weekly REM command *)
|
|
|
|
type simple_daily = {
|
|
count_or_until : Icalendar.count_or_until option;
|
|
interval : int option; (** Optional interval for daily recurrence, default is 1 *)
|
|
week_start : week_first_day option; (** First day of the week for weekly recurrence *)
|
|
}
|
|
(** A simple daily REM command *)
|
|
|
|
type monthly_pattern =
|
|
| By_month_day of int (** P07: BYMONTHDAY=n or implicit day from DTSTART *)
|
|
| By_nth_weekday of int * Icalendar.weekday (** P08: BYDAY=nWD, n≠0, can be negative *)
|
|
|
|
type simple_monthly = {
|
|
count_or_until : Icalendar.count_or_until option;
|
|
interval : int option;
|
|
pattern : monthly_pattern;
|
|
}
|
|
(** A simple monthly REM command *)
|
|
|
|
type rem = {
|
|
source : string; (** Source file or identifier for the reminder *)
|
|
original_uuid : string; (** Original UID from the iCalendar event *)
|
|
original_event : Icalendar.event option; (** The original iCalendar event *)
|
|
summary : string; (** Summary or title of the reminder *)
|
|
location : string option; (** Optional location of the event *)
|
|
description : string option; (** Optional description of the event *)
|
|
conference_url : string option; (** Optional conference URL for virtual meetings *)
|
|
date : Timedesc.Date.t; (** Date specification (day, month, year) *)
|
|
end_date : Timedesc.Date.t option; (** Optional end date for a date range *)
|
|
time : Timedesc.Time.t option; (** Optional time specification (hour, minute) *)
|
|
duration : Timedesc.Span.t option; (** Optional duration for timed events *)
|
|
yearly : (int * int) option; (** Optional simple yearly recurrence (month, day) *)
|
|
monthly : simple_monthly option; (** Optional simple monthly recurrence *)
|
|
weekly : simple_weekly option; (** Optional simple weekly recurrence *)
|
|
daily : simple_daily option; (** Optional simple daily recurrence *)
|
|
recurring : Icalendar.event list;
|
|
(** List of events that are part of the same recurring series: these are only the overrides, not the master event
|
|
*)
|
|
exdate : Icalendar.date_or_datetime list; (** List of excluded dates for recurring events *)
|
|
overrides : rem list; (** Single-event REMs generated from non-cancelled RECURRENCE-ID overrides *)
|
|
tz : Timedesc.Time_zone.t option; (** Timezone of the event's DTSTART, used for UNTIL conversion *)
|
|
triggers : Timedesc.Span.t list; (** List of trigger offsets for alarms, in seconds *)
|
|
}
|
|
(** A complete REM command *)
|
|
|
|
let empty =
|
|
{
|
|
source = "";
|
|
original_uuid = "";
|
|
original_event = None;
|
|
summary = "";
|
|
location = None;
|
|
description = None;
|
|
conference_url = None;
|
|
date = Timedesc.Date.Ymd.make_exn ~year:1970 ~month:1 ~day:1;
|
|
end_date = None;
|
|
time = None;
|
|
duration = None;
|
|
yearly = None;
|
|
monthly = None;
|
|
weekly = None;
|
|
daily = None;
|
|
recurring = [];
|
|
exdate = [];
|
|
overrides = [];
|
|
tz = None;
|
|
triggers = [];
|
|
}
|
|
|
|
(* ── alarm rendering ─────────────────────────────────────────── *)
|
|
|
|
(** Global counter for generating unique WARN/SCHED function names *)
|
|
let alarm_id = ref 0
|
|
|
|
let next_alarm_id () =
|
|
incr alarm_id;
|
|
!alarm_id
|
|
|
|
(** Convert a Timedesc.Span.t to signed total minutes. Negative = before event; positive = after event. *)
|
|
let span_to_minutes (sp : Timedesc.Span.t) : int =
|
|
let v = Timedesc.Span.For_human.view sp in
|
|
let sign =
|
|
match v.Timedesc.Span.For_human.sign with
|
|
| `Pos -> 1
|
|
| `Neg -> -1
|
|
in
|
|
sign * ((v.days * 1440) + (v.hours * 60) + v.minutes)
|
|
|
|
(** For timed events: keep only negative triggers, convert to positive minutes-before-event, sort ascending (closest to
|
|
event first, suitable for SCHED sequence). *)
|
|
let timed_trigger_minutes (triggers : Timedesc.Span.t list) : int list =
|
|
triggers
|
|
|> List.filter_map (fun sp ->
|
|
let m = span_to_minutes sp in
|
|
if m >= 0 then None else Some (-m))
|
|
|> List.sort_uniq compare
|
|
|
|
(** For all-day events: keep only negative triggers, convert to days-before-event (ceiling, min 1), deduplicate, sort
|
|
descending (furthest first, suitable for WARN sequence). *)
|
|
let allday_trigger_days (triggers : Timedesc.Span.t list) : int list =
|
|
triggers
|
|
|> List.filter_map (fun sp ->
|
|
let m = span_to_minutes sp in
|
|
if m >= 0 then None
|
|
else
|
|
let abs_min = -m in
|
|
let days = max 1 ((abs_min + 1439) / 1440) in
|
|
Some days)
|
|
|> List.sort_uniq compare
|
|
|> List.rev
|
|
|
|
type alarm_rendering = {
|
|
fset : string; (** FSET line(s) to emit before REM, empty if none *)
|
|
day_delta : string; (** "++n " or "WARN name " or "" — inserted in trigger spec *)
|
|
time_delta : string; (** "+n " or "" — appended after AT time (single timed trigger) *)
|
|
sched : string; (** "SCHED name " or "" — appended after AT clause (multiple timed triggers) *)
|
|
}
|
|
|
|
let empty_alarm = { fset = ""; day_delta = ""; time_delta = ""; sched = "" }
|
|
|
|
(** Compute alarm rendering for a rem, depending on whether the event is timed or all-day and whether there are one or
|
|
multiple triggers. *)
|
|
let render_alarm (rem : rem) : alarm_rendering =
|
|
match rem.triggers with
|
|
| [] -> empty_alarm
|
|
| triggers ->
|
|
if rem.time <> None then
|
|
(* Timed event *)
|
|
begin match timed_trigger_minutes triggers with
|
|
| [] -> empty_alarm
|
|
| [ n ] -> { empty_alarm with time_delta = spf "+%d " n }
|
|
| mins ->
|
|
let id = next_alarm_id () in
|
|
let name = spf "sched_%d" id in
|
|
(* SCHED sequence: most-advance first (most negative), then 0 to stop.
|
|
mins is sorted ascending (closest first), so reverse for SCHED order. *)
|
|
let sched_vals = List.rev_map (fun n -> spf "%d" (-n)) mins @ [ "0" ] in
|
|
let fset = spf "FSET %s(x) choose(x, %s)\n" name (String.concat ", " sched_vals) in
|
|
{ empty_alarm with fset; sched = spf "SCHED %s " name }
|
|
end
|
|
else
|
|
(* All-day event *)
|
|
begin match allday_trigger_days triggers with
|
|
| [] -> empty_alarm
|
|
| [ n ] -> { empty_alarm with day_delta = spf "++%d " n }
|
|
| days ->
|
|
let id = next_alarm_id () in
|
|
let name = spf "warn_%d" id in
|
|
(* WARN sequence: furthest first (days sorted descending), then 0 to stop. *)
|
|
let warn_vals = List.map string_of_int (days @ [ 0 ]) in
|
|
let fset = spf "FSET %s(x) choose(x, %s)\n" name (String.concat ", " warn_vals) in
|
|
{ empty_alarm with fset; day_delta = spf "WARN %s " name }
|
|
end
|
|
|
|
(* ── buffer primitives ────────────────────────────────────────── *)
|
|
|
|
let add_rem b = Buffer.add_string b "REM "
|
|
let add_uid b uuid = Buffer.add_string b (spf "\\\n INFO \"UID: %s\" " uuid)
|
|
let add_source b source = Buffer.add_string b (spf "\\\n INFO \"Calendar: %s\" " (String.uppercase_ascii source))
|
|
let add_date b date = Buffer.add_string b (Timedesc.Date.to_rfc3339 date)
|
|
let add_weekday b wd = Buffer.add_string b (spf "%s " (string_of_weekday wd))
|
|
|
|
let add_interval b (w : simple_weekly) =
|
|
let n = Option.value ~default:1 w.interval in
|
|
Buffer.add_string b (spf "*%d " (n * 7))
|
|
|
|
let add_interval_daily b (d : simple_daily) =
|
|
let n = Option.value ~default:1 d.interval in
|
|
Buffer.add_string b (spf "*%d " n)
|
|
|
|
(** Adjust an UNTIL date: if the event has a start time and the local time of the UNTIL timestamp is strictly before
|
|
that start time, the last valid occurrence is on the previous day. *)
|
|
let until_date_adjusted (until_ts : Timedesc.t) (event_time : Timedesc.Time.t option) : Timedesc.Date.t =
|
|
let until_date = Timedesc.date until_ts in
|
|
match event_time with
|
|
| None -> until_date
|
|
| Some evt_t ->
|
|
let until_t = Timedesc.time until_ts in
|
|
let cmp = Timedesc.Span.compare (Timedesc.Time.to_span until_t) (Timedesc.Time.to_span evt_t) in
|
|
if cmp < 0 then Timedesc.Date.add ~days:(-1) until_date else until_date
|
|
|
|
let add_until b rem (w : simple_weekly) =
|
|
match w.count_or_until with
|
|
| None -> ()
|
|
| Some (`Until d) ->
|
|
let tz = Option.value ~default:(Timedesc.Time_zone.local_exn ()) rem.tz in
|
|
let ts = timedesc_of_utc_or_timestamp_tz tz d in
|
|
let date = until_date_adjusted ts rem.time in
|
|
Buffer.add_string b (spf "UNTIL %s " (Timedesc.Date.to_rfc3339 date))
|
|
| Some (`Count count) ->
|
|
let wd = Timedesc.Date.weekday rem.date in
|
|
let wd_int = Timedesc.Utils.tm_int_of_weekday wd in
|
|
let sub =
|
|
match w.week_start with
|
|
| Some `Monday -> wd_int - 1
|
|
| _ -> wd_int
|
|
in
|
|
let iv = Option.value ~default:1 w.interval in
|
|
let until = Timedesc.Date.add ~days:((count * 7 * iv) - sub) rem.date in
|
|
Buffer.add_string b (spf "UNTIL %s " (Timedesc.Date.to_rfc3339 until))
|
|
|
|
let add_until_daily b rem (d : simple_daily) =
|
|
match d.count_or_until with
|
|
| None -> ()
|
|
| Some (`Until dt) ->
|
|
let tz = Option.value ~default:(Timedesc.Time_zone.local_exn ()) rem.tz in
|
|
let ts = timedesc_of_utc_or_timestamp_tz tz dt in
|
|
let date = until_date_adjusted ts rem.time in
|
|
Buffer.add_string b (spf "UNTIL %s " (Timedesc.Date.to_rfc3339 date))
|
|
| Some (`Count count) ->
|
|
let iv = Option.value ~default:1 d.interval in
|
|
let until = Timedesc.Date.add ~days:((count - 1) * iv) rem.date in
|
|
Buffer.add_string b (spf "UNTIL %s " (Timedesc.Date.to_rfc3339 until))
|
|
|
|
let add_until_monthly b rem (m : simple_monthly) =
|
|
match m.count_or_until with
|
|
| None -> ()
|
|
| Some (`Until dt) ->
|
|
let tz = Option.value ~default:(Timedesc.Time_zone.local_exn ()) rem.tz in
|
|
let ts = timedesc_of_utc_or_timestamp_tz tz dt in
|
|
let date = until_date_adjusted ts rem.time in
|
|
Buffer.add_string b (spf "UNTIL %s " (Timedesc.Date.to_rfc3339 date))
|
|
| Some (`Count count) ->
|
|
let base = Utils.add_months rem.date (count - 1) in
|
|
let until =
|
|
match m.pattern with
|
|
| By_month_day _ -> base
|
|
| By_nth_weekday _ -> Timedesc.Date.add ~days:6 base (* weekday can shift up to 6 days *)
|
|
in
|
|
Buffer.add_string b (spf "UNTIL %s " (Timedesc.Date.to_rfc3339 until))
|
|
|
|
let add_at b (alarm : alarm_rendering) = function
|
|
| Some t -> Buffer.add_string b (spf " AT %s %s%s" (string_of_time t) alarm.time_delta alarm.sched)
|
|
| None -> ()
|
|
|
|
let add_duration b = function
|
|
| Some d -> Buffer.add_string b (spf " DURATION %s" (string_of_span d))
|
|
| None -> ()
|
|
|
|
let add_through b = function
|
|
| Some d -> Buffer.add_string b (spf " THROUGH %s" (Timedesc.Date.to_rfc3339 d))
|
|
| None -> ()
|
|
|
|
(** Escape special characters in the body of a MSG clause.
|
|
- '%' must become '%%' (literal percent)
|
|
- '[' must become '["["]' (a Remind expression that evaluates to the literal string "[") *)
|
|
let escape_msg s =
|
|
let buf = Buffer.create (String.length s) in
|
|
String.iter
|
|
(function
|
|
| '\n' -> Buffer.add_string buf "\\n"
|
|
| '\t' -> ()
|
|
| '"' -> Buffer.add_string buf "\\\""
|
|
| '%' -> Buffer.add_string buf "%%"
|
|
| '[' -> Buffer.add_string buf {|["["]|}
|
|
| c -> Buffer.add_char buf c)
|
|
s;
|
|
Buffer.contents buf
|
|
|
|
let add_msg b ?(alarm = empty_alarm) ?(timed = false) summary =
|
|
let has_alarm = alarm.day_delta <> "" || alarm.time_delta <> "" || alarm.sched <> "" in
|
|
let body = escape_msg summary in
|
|
let body = if has_alarm then if timed then spf "%%\"%s%%\" (%%1)" body else spf "%%\"%s%%\" (%%b)" body else body in
|
|
Buffer.add_string b (spf " MSG %s\n" body)
|
|
|
|
let add_location b loc =
|
|
match loc with
|
|
| Some loc -> begin
|
|
let loc = String.trim loc in
|
|
Buffer.add_string b (spf "\\\n INFO \"Location: %s\" " (escape_msg loc))
|
|
end
|
|
| None -> ()
|
|
|
|
let add_description b desc =
|
|
match desc with
|
|
| Some desc ->
|
|
let desc = String.trim desc in
|
|
Buffer.add_string b (spf "\\\n INFO \"Description: %s\" " (escape_msg desc))
|
|
| None -> ()
|
|
|
|
let add_url b url =
|
|
match url with
|
|
| Some url ->
|
|
let url = String.trim url in
|
|
Buffer.add_string b (spf "\\\n INFO \"Url: %s\" " (escape_msg url))
|
|
| None -> ()
|
|
|
|
let add_common_part b rem =
|
|
add_rem b;
|
|
add_uid b rem.original_uuid;
|
|
add_source b rem.source;
|
|
add_location b rem.location;
|
|
add_description b rem.description;
|
|
add_url b rem.conference_url
|
|
|
|
let date_of_date_or_datetime (d : Icalendar.date_or_datetime) : Timedesc.Date.t =
|
|
match d with
|
|
| `Date (year, month, day) -> Timedesc.Date.Ymd.make_exn ~year ~month ~day
|
|
| `Datetime ts -> Timedesc.date (timedesc_of_timestamp ts)
|
|
|
|
let add_omit b (d : Icalendar.date_or_datetime) =
|
|
let date = date_of_date_or_datetime d in
|
|
let day = Timedesc.Date.day date in
|
|
let month = string_of_month (month_of_int (Timedesc.Date.month date)) in
|
|
let year = Timedesc.Date.year date in
|
|
Buffer.add_string b (spf "OMIT %d %s %d\n" day month year)
|
|
|
|
let add_omit_context b exdates =
|
|
if exdates <> [] then begin
|
|
Buffer.add_string b "PUSH-OMIT-CONTEXT\n";
|
|
List.iter (add_omit b) exdates
|
|
end
|
|
|
|
let close_omit_context b exdates = if exdates <> [] then Buffer.add_string b "POP-OMIT-CONTEXT\n"
|
|
let add_skip b exdates = if exdates <> [] then Buffer.add_string b "SKIP "
|
|
|
|
(* ── rendering ────────────────────────────────────────────────── *)
|
|
|
|
let render_daily rem (d : simple_daily) =
|
|
let b = Buffer.create 256 in
|
|
let alarm = render_alarm rem in
|
|
Buffer.add_string b alarm.fset;
|
|
add_omit_context b rem.exdate;
|
|
add_common_part b rem;
|
|
add_date b rem.date;
|
|
Buffer.add_char b ' ';
|
|
add_interval_daily b d;
|
|
add_until_daily b rem d;
|
|
Buffer.add_string b alarm.day_delta;
|
|
add_skip b rem.exdate;
|
|
add_at b alarm rem.time;
|
|
add_duration b rem.duration;
|
|
add_msg b ~alarm ~timed:(rem.time <> None) rem.summary;
|
|
close_omit_context b rem.exdate;
|
|
Buffer.contents b
|
|
|
|
let render_weekly rem (w : simple_weekly) =
|
|
let b = Buffer.create 256 in
|
|
let alarm = render_alarm rem in
|
|
Buffer.add_string b alarm.fset;
|
|
add_omit_context b rem.exdate;
|
|
List.iter
|
|
(fun wd ->
|
|
add_common_part b rem;
|
|
add_weekday b wd;
|
|
add_date b rem.date;
|
|
Buffer.add_char b ' ';
|
|
add_interval b w;
|
|
add_until b rem w;
|
|
Buffer.add_string b alarm.day_delta;
|
|
add_skip b rem.exdate;
|
|
add_at b alarm rem.time;
|
|
add_duration b rem.duration;
|
|
add_msg b ~alarm ~timed:(rem.time <> None) rem.summary)
|
|
w.byday;
|
|
close_omit_context b rem.exdate;
|
|
Buffer.contents b
|
|
|
|
let render_monthly rem (m : simple_monthly) =
|
|
let b = Buffer.create 256 in
|
|
let alarm = render_alarm rem in
|
|
Buffer.add_string b alarm.fset;
|
|
add_omit_context b rem.exdate;
|
|
add_common_part b rem;
|
|
(match m.pattern with
|
|
| By_month_day day -> Buffer.add_string b (spf "%d " day)
|
|
| By_nth_weekday (n, wd) when n > 0 ->
|
|
let day = ((n - 1) * 7) + 1 in
|
|
add_weekday b wd;
|
|
Buffer.add_string b (spf "%d " day)
|
|
| By_nth_weekday (n, wd) (* n < 0 *) ->
|
|
let back = -n * 7 in
|
|
add_weekday b wd;
|
|
Buffer.add_string b (spf "1 --%d " back));
|
|
Buffer.add_string b (spf "FROM %s " (Timedesc.Date.to_rfc3339 rem.date));
|
|
add_until_monthly b rem m;
|
|
Buffer.add_string b alarm.day_delta;
|
|
add_skip b rem.exdate;
|
|
add_at b alarm rem.time;
|
|
add_duration b rem.duration;
|
|
add_msg b ~alarm ~timed:(rem.time <> None) rem.summary;
|
|
close_omit_context b rem.exdate;
|
|
Buffer.contents b
|
|
|
|
let render_single rem =
|
|
let b = Buffer.create 256 in
|
|
let alarm = render_alarm rem in
|
|
Buffer.add_string b alarm.fset;
|
|
add_common_part b rem;
|
|
add_date b rem.date;
|
|
Buffer.add_char b ' ';
|
|
Buffer.add_string b alarm.day_delta;
|
|
add_at b alarm rem.time;
|
|
add_duration b rem.duration;
|
|
add_through b rem.end_date;
|
|
add_msg b ~alarm ~timed:(rem.time <> None) rem.summary;
|
|
Buffer.contents b
|
|
|
|
let render_yearly rem month day =
|
|
let b = Buffer.create 64 in
|
|
let alarm = render_alarm rem in
|
|
Buffer.add_string b alarm.fset;
|
|
add_common_part b rem;
|
|
Buffer.add_string b (spf "%s %d " (month_of_int month |> string_of_month) day);
|
|
Buffer.add_string b alarm.day_delta;
|
|
add_at b alarm rem.time;
|
|
add_msg b ~alarm ~timed:(rem.time <> None) rem.summary;
|
|
Buffer.contents b
|
|
|
|
(* ── dispatcher ───────────────────────────────────────────────── *)
|
|
|
|
let string_of_rem rem =
|
|
let main =
|
|
match rem.daily with
|
|
| Some d -> render_daily rem d
|
|
| None -> (
|
|
match rem.weekly with
|
|
| Some w -> render_weekly rem w
|
|
| None -> (
|
|
match rem.monthly with
|
|
| Some m -> render_monthly rem m
|
|
| None -> (
|
|
match rem.yearly with
|
|
| Some (month, day) -> render_yearly rem month day
|
|
| None -> render_single rem)))
|
|
in
|
|
let overrides = List.map render_single rem.overrides in
|
|
String.concat "" (main :: overrides)
|