diff --git a/.ocamlformat b/.ocamlformat index 54298f6..7f0213f 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,19 +1,7 @@ +profile = default version = 0.29.0 -profile = conventional +margin = 120 break-cases = fit-or-vertical break-infix = fit-or-vertical -break-separators = after -cases-exp-indent = 2 exp-grouping = preserve -if-then-else = keyword-first -leading-nested-match-parens = false -let-and = sparse -margin = 120 -space-around-arrays = false -space-around-lists = false -space-around-records = false -space-around-records = true -space-around-variants = false -type-decl = sparse -wrap-fun-args = false diff --git a/bin/dune b/bin/dune index 3f8c71e..1d64537 100644 --- a/bin/dune +++ b/bin/dune @@ -1,11 +1,11 @@ (executable (public_name remind_sync) (name main) - (modules main commandLine remind eventTransformer eventPredicates utils) + (modules main commandLine remind eventPredicates utils) (preprocess (pps ppx_deriving.show)) (libraries - ;remind_sync + remind_sync cmdliner icalendar timedesc-tzdb.full diff --git a/bin/eventPredicates.ml b/bin/eventPredicates.ml index a031247..3718a4d 100644 --- a/bin/eventPredicates.ml +++ b/bin/eventPredicates.ml @@ -1,3 +1,4 @@ +open Remind_sync open Icalendar open Utils @@ -172,186 +173,159 @@ open Utils *) type event_description = - [ `Has_summary (* P00 *) - | `All_day_event_single (* P01 *) - | `All_day_event_multi (* P02 *) - | `Timed_event (* P03 and P04 *) - | `Weekly_simple_recurrence (* P05 *) - | `Daily_simple_recurrence (* P06 *) - | `Exception_events (* P10 *) - | `Override_events (* P11 *) ] + [ `Collect_uuid | `Has_summary | `All_day_event | `Expand_recurrence | `Simple_weekly_recurrence ] [@@deriving show] -type features = - | Generic_feature_presence (* TODO: TO BE REMOVED *) - | Summary of string - | Day_start of int * int * int (* year, month, day *) - | Multi_day of int (* number of days *) -[@@deriving show] +type error = Invalid_date of string | Skip [@@deriving show] -type predicate = Icalendar.event -> features list option +let invalid_date s e = + Error (Invalid_date (spf "Invalid date: %s, error: %s" s (Remind_sync.Timedesc.Date.Ymd.show_error e))) -let has_summary ev : features list option = - (* P00 *) +let skip = Error Skip + +type collector = Remind.rem -> event -> (Remind.rem, error) result + +let collect_uuid rem ev : (Remind.rem, error) result = + let uid = Utils.get_uid ev in + Ok { rem with Remind.original_uuid = uid } + +let collect_summary rem ev : (Remind.rem, error) result = let summary_opt = List.find_map (function - | `Summary (_, s) -> Some [Summary s] + | `Summary (_, s) -> Some s | _ -> None) ev.props in match summary_opt with - | Some s -> Some s - | None -> None + | Some s -> Ok { rem with Remind.summary = s } + | None -> Ok { rem with Remind.summary = "" } -let all_day_event_single ev : features list option = - (* P01 *) +let collect_start_end_duration rem ev : (Remind.rem, error) result = let _, dtstart = ev.dtstart in match dtstart with - | `Date d -> - begin match ev.dtend_or_duration with - | None -> - let y, m, d = get_y_m_d_from_timedesc (get_start ev) in - Some [Day_start (y, m, d)] - | Some (`Dtend (_, `Date end_)) -> begin - let start_dt = Ptime.of_date d |> Option.get in - let end_dt = Ptime.of_date end_ |> Option.get in - if Ptime.diff end_dt start_dt = Ptime.Span.of_int_s 86400 - then - let y, m, d = get_y_m_d_from_timedesc (get_start ev) in - Some [Day_start (y, m, d)] - else None - end - | _ -> None - end - | _ -> None + | `Date (year, month, day) -> ( + match Timedesc.Date.Ymd.make ~year ~month ~day with + | Error e -> invalid_date "DTSTART" e + | Ok day_start -> + begin match ev.dtend_or_duration with + | None -> { rem with Remind.date = day_start } |> Result.ok + | Some (`Dtend (_, `Datetime _)) -> skip + | Some (`Dtend (_, `Date (year, month, day))) -> + begin match Timedesc.Date.Ymd.make ~year ~month ~day with + | Error e -> invalid_date "DTEND" e + | Ok day_end -> + let day_end = Timedesc.Date.add ~days:(-1) day_end in + if Timedesc.Date.diff_days day_end day_start = 0 then + Ok { rem with Remind.date = day_start; Remind.end_date = None } + else Ok { rem with Remind.date = day_start; Remind.end_date = Some day_end } + end + | Some (`Duration (_, _duration)) -> skip + end) + | `Datetime datetime -> begin + let start_td = Utils.timedesc_of_timestamp datetime in + let rem = { rem with Remind.date = Timedesc.date start_td; Remind.time = Some (Timedesc.time start_td) } in -let all_day_event_multi ev : features list option = - (* P02 *) - let _, dtstart = ev.dtstart in - match dtstart with - | `Date d -> - begin match ev.dtend_or_duration with - | None -> None - | Some (`Dtend (_, `Date end_)) -> begin - let start_dt = Ptime.of_date d |> Option.get in - let end_dt = Ptime.of_date end_ |> Option.get in - if Ptime.diff end_dt start_dt > Ptime.Span.of_int_s 86400 - then - (* Actually compute the number of days *) - let num_days = Ptime.diff end_dt start_dt |> Ptime.Span.to_int_s |> fun s -> Option.get s / 86400 in - let y, m, d = get_y_m_d_from_timedesc (get_start ev) in - Some [Day_start (y, m, d); Multi_day num_days] - else None - end - | Some (`Duration (_, span)) -> begin - let days, _ps = Ptime.Span.to_d_ps span in - let y, m, d = get_y_m_d_from_timedesc (get_start ev) in - Some [Day_start (y, m, d); Multi_day days] - end - | Some (`Dtend (_, `Datetime _)) -> None - end - | _ -> None - -let timed_event ev : features list option = - (* P03 and P04 *) - let _, dtstart = ev.dtstart in - let start_td = get_start ev in - let uid = get_uid ev in - match dtstart with - | `Datetime (`Local _) -> begin - Printf.printf "Local time event: %s\n" uid; - Printf.printf " Timedesc: %s\n" (start_td |> Timedesc.to_rfc3339); - Some [Generic_feature_presence] - end - | `Datetime (`Utc ts) -> begin - Printf.printf "UTC time event: %s, time: %s\n" uid (Ptime.to_rfc3339 ts); - Printf.printf " Timedesc: %s\n" (start_td |> Timedesc.to_rfc3339); - Some [Generic_feature_presence] - end - | `Datetime (`With_tzid (ts, (b, tz_name))) -> begin - Printf.printf "With TZID event: %s, TZID: (%b, %s), time: %s\n" uid b tz_name (Ptime.to_rfc3339 ts); - Printf.printf " Timedesc: %s\n" (start_td |> Timedesc.to_rfc3339); - Some [Generic_feature_presence] - end - | `Date (y, m, d) -> begin - Printf.printf "All-day event (date): %s, date: %04d-%02d-%02d\n" uid y m d; - Printf.printf " Timedesc: %s\n" (start_td |> Timedesc.to_rfc3339); - None + match ev.dtend_or_duration with + | None -> Ok rem + | Some (`Dtend (_, date_or_datetime)) -> + begin match date_or_datetime with + | `Datetime datetime -> begin + let end_td = Utils.timedesc_of_timestamp datetime in + let duration = + Timedesc.Span.sub (Timedesc.to_timestamp_single end_td) (Timedesc.to_timestamp_single start_td) + in + let rem = { rem with Remind.duration = Some duration } in + Ok rem + end + | `Date (_year, _month, _day) -> skip + end + | Some (`Duration (_, duration)) -> + let span = Timedesc.Utils.span_of_ptime_span duration in + let rem = { rem with Remind.duration = Some span } in + Ok rem end -let weekly_simple_recurrence ev : features list option = - (* P05 *) - let rrules = ev.rrule in - match rrules with - | None -> None - | Some (_, (`Weekly, _, _, _)) -> begin - Printf.printf " Weekly simple recurrence event\n"; - Some [Generic_feature_presence] - end - | _ -> None +let expand_recurrence rem ev : (Remind.rem, error) result = + if List.length rem.Remind.recurring > 0 then skip else Ok rem -let daily_simple_recurrence ev : features list option = - (* P06 *) - let rrules = ev.rrule in - match rrules with - | None -> None - | Some (_, (`Daily, _, _, _)) -> begin - Printf.printf " Daily simple recurrence event\n"; - Some [Generic_feature_presence] - end - | _ -> None +let simple_weekly_recurrence rem ev : (Remind.rem, error) result = + match ev.rrule with + (* +type recur = + [ `Byminute of int list + | `Byday of (int * weekday) list + | `Byhour of int list + | `Bymonth of int list + | `Bymonthday of int list + | `Bysecond of int list + | `Bysetposday of int list + | `Byweek of int list + | `Byyearday of int list + | `Weekday of weekday ] +[@@deriving show] -let exception_events ev : features list option = - (* P10 *) - let exdates = get_exdates ev in - let rdates = get_rdates ev in - if exdates <> [] || rdates <> [] - then begin - Printf.printf " Exception event: %s\n" (get_uid ev); - Some [Generic_feature_presence] - end - else None +type freq = [ `Daily | `Hourly | `Minutely | `Monthly | `Secondly | `Weekly | `Yearly ] [@@deriving show] +type count_or_until = [ `Count of int | `Until of utc_or_timestamp_local (* TODO date or datetime *) ] [@@deriving show] +type interval = int [@@deriving show] +type recurrence = freq * count_or_until option * interval option * recur list [@@deriving show] -let override_events ev : features list option = - (* P11 *) - let props = ev.props in - let recur_date_or_datetime_opt = - List.find_map - (function - | `Recur_id (_, date_or_datetime) -> Some date_or_datetime - | _ -> None) - props - in - let status_cancelled_opt = - List.find_map - (function - | `Status (_, `Cancelled) -> Some () - | _ -> None) - props - in - match status_cancelled_opt with - | Some () -> begin - Printf.printf " Override event (cancelled): %s\n" (get_uid ev); - Some [Generic_feature_presence] - end - | None -> - begin match recur_date_or_datetime_opt with - | Some _ -> begin - Printf.printf " Override event (modified instance): %s\n" (get_uid ev); - Some [Generic_feature_presence] - end - | None -> None - end +QUESTE SONO **TUTTE** LE RRULE NEL MIO DATASET -let all_predicates : (predicate * event_description) list = +RRULE: (`Daily, (Some `Count (11)), None, []) +RRULE: (`Daily, (Some `Until (`Utc (2008-05-11 11:15:00 +00:00))), None, [`Weekday (`Monday)]) +RRULE: (`Daily, (Some `Until (`Utc (2026-02-04 13:30:00 +00:00))), (Some 1), []) +RRULE: (`Weekly, (Some `Count (3)), None, [`Byday ([(0, `Wednesday)])]) +RRULE: (`Weekly, (Some `Until (`Utc (2009-07-31 18:00:00 +00:00))), None, [`Byday ([(0, `Tuesday); (0, `Friday)]); `Weekday (`Monday)]) +RRULE: (`Weekly, (Some `Until (`Utc (2013-04-18 17:30:00 +00:00))), None, [`Byday ([(0, `Monday); (0, `Thursday)])]) +RRULE: (`Weekly, (Some `Until (`Utc (2014-12-20 10:30:00 +00:00))), None, [`Byday ([(0, `Saturday)])]) +RRULE: (`Weekly, (Some `Until (`Utc (2020-09-16 21:59:59 +00:00))), None, [`Byday ([(0, `Thursday)])]) +RRULE: (`Weekly, (Some `Until (`Utc (2021-08-25 21:59:59 +00:00))), None, [`Byday ([(0, `Wednesday)]); `Weekday (`Monday)]) +RRULE: (`Weekly, (Some `Until (`Utc (2021-09-18 21:59:59 +00:00))), (Some 1), [`Byday ([(0, `Sunday)]); `Weekday (`Monday)]) +RRULE: (`Weekly, (Some `Until (`Utc (2024-06-12 08:00:00 +00:00))), (Some 4), [`Weekday (`Sunday); `Byday ([(0, `Wednesday)])]) +RRULE: (`Weekly, (Some `Until (`Utc (2025-02-04 22:59:59 +00:00))), (Some 1), [`Weekday (`Sunday); `Byday ([(0, `Wednesday)])]) +RRULE: (`Weekly, (Some `Until (`Utc (2025-06-22 21:59:59 +00:00))), (Some 1), [`Weekday (`Monday); `Byday ([(0, `Monday)])]) +RRULE: (`Weekly, (Some `Until (`Utc (2026-02-24 22:59:59 +00:00))), (Some 2), [`Weekday (`Monday); `Byday ([(0, `Tuesday)])]) +RRULE: (`Weekly, (Some `Until (`Utc (2026-03-25 00:00:00 +00:00))), None, [`Weekday (`Monday); `Byday ([(0, `Wednesday)])]) +RRULE: (`Weekly, (Some `Until (`Utc (2026-07-01 09:00:00 +00:00))), None, []) +RRULE: (`Yearly, None, None, []) + +Il file RRULE_all.txt contiene tutte le RRULE del mio dataset! + +*) + | Some (_, (freq, count_or_until, interval, recurs)) -> + let _recur = (freq, count_or_until, interval, recurs) in + let uid = Utils.get_uid ev in + Printf.eprintf "RRULE: %s\t\t\tUID: %s\n" (Icalendar.show_recurrence _recur) uid; + skip + (* TODO: implementare *) + | None -> Ok rem + +let all_collectors : (collector * event_description) list = [ - (has_summary, `Has_summary); - (all_day_event_single, `All_day_event_single); - (all_day_event_multi, `All_day_event_multi); - (timed_event, `Timed_event); - (weekly_simple_recurrence, `Weekly_simple_recurrence); - (daily_simple_recurrence, `Daily_simple_recurrence); - (exception_events, `Exception_events); - (override_events, `Override_events); + (collect_uuid, `Collect_uuid); + (collect_summary, `Has_summary); + (collect_start_end_duration, `All_day_event); + (expand_recurrence, `Expand_recurrence); + (simple_weekly_recurrence, `Simple_weekly_recurrence); ] + +let remind_of_event (ev : Icalendar.event list) : (Remind.rem, error) result = + let () = if List.length ev = 0 then failwith "No events provided" in + + let master, recurrence = + if List.length ev > 1 then begin + separate_master_and_recurrence ev + end + else begin + let ev = List.hd ev in + (ev, []) + end + in + + let rem = { Remind.empty with Remind.recurring = recurrence } in + + ListLabels.fold_left ~init:(Ok rem) all_collectors ~f:(fun rem_or_error (pred, _desc) -> + match rem_or_error with + | Error e -> Error e + | Ok rem -> pred rem master) diff --git a/bin/eventTransformer.ml b/bin/eventTransformer.ml deleted file mode 100644 index 8930584..0000000 --- a/bin/eventTransformer.ml +++ /dev/null @@ -1,21 +0,0 @@ -let default_implementation = Remind.make_default_event "TODO: implement conversion" - -let remind_of_event (ev : Icalendar.event) : Remind.event = - let found = - ListLabels.fold_left ~init:[] EventPredicates.all_predicates ~f:(fun acc (pred, desc) -> - match pred ev with - | Some feats -> (desc, feats) :: acc - | None -> acc) - |> List.rev - in - if List.length found > 0 - then begin - Printf.printf " \u{f04d3} \u{21d2} matches these predicates:\n"; - ListLabels.iter - ~f:(fun (desc, features) -> - Printf.printf " - %s\n" (EventPredicates.show_event_description desc); - ListLabels.iter ~f:(fun feat -> Printf.printf " - %s\n" (EventPredicates.show_features feat)) features) - found; - Printf.printf "\n" - end; - default_implementation diff --git a/bin/main.ml b/bin/main.ml index 42d304d..75cedfd 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -1,6 +1,6 @@ +open Remind_sync module Map = MoreLabels.Map.Make (String) -type event = Icalendar.event list (* We use a list of events here because there can be multiple events with the same UID, and we want to preserve all of them. This is important for handling cases where there are multiple events with the same UID but different properties @@ -15,43 +15,30 @@ let ical2rem ical_file = close_in ic; let cal_or_error = Icalendar.parse (Bytes.unsafe_to_string s) in match cal_or_error with - | Error e -> prerr_endline ("Error parsing iCalendar file: " ^ e) + | Error e -> + if e = ": not enough input" then + exit 0 (* This is a common error when the file is empty, so we treat it as a non-error case *) + else prerr_endline ("Error parsing iCalendar file: " ^ e) | Ok (_, components) -> begin - let events_map : event Map.t = - ListLabels.fold_left ~init:Map.empty components ~f:(fun acc comp -> - match comp with - | `Event ev -> - let uid = Utils.get_uid ev in - let event_list = Map.find_opt uid acc |> Option.value ~default:[] in - Map.add ~key:uid ~data:(ev :: event_list) acc - | _ -> acc (* Ignore non-event components *)) - in + let events_map : Icalendar.event list Map.t = + ListLabels.fold_left ~init:Map.empty components ~f:(fun acc comp -> + match comp with + | `Event ev -> + let uid = Utils.get_uid ev in + let event_list = Map.find_opt uid acc |> Option.value ~default:[] in + Map.add ~key:uid ~data:(ev :: event_list) acc + | _ -> acc (* Ignore non-event components *)) + in + (* Now revert all the lists *) + let events_map = Map.map ~f:List.rev events_map in + (* Printf.printf "Events: %d\n\n" (Map.cardinal events_map); *) - (* Now revert all the lists *) - let events_map = Map.map ~f:List.rev events_map in - - (* let () = *) - (* Map.iter *) - (* ~f:(fun ~key ~data -> *) - (* let uid = key in *) - (* let evs = data in *) - (* Printf.printf "󰧓 ⇒ UID: %s\n" uid; *) - (* List.iter (fun ev -> Printf.printf "%s\n" (Icalendar.show_component (`Event ev))) evs; *) - (* Printf.printf "\n\n") *) - (* events_map *) - (* in *) - Printf.printf "Events: %d\n\n" (Map.cardinal events_map); - let events = - List.filter_map - (function - | `Event ev -> Some ev - | _ -> None) - components - in - - let _reminders = List.map EventTransformer.remind_of_event events in - - () + Map.iter events_map ~f:(fun ~key:uid ~data:events -> + let rem_or_error = EventPredicates.remind_of_event events in + match rem_or_error with + | Ok rem -> begin Printf.printf "%s\n" (Remind.string_of_rem rem) end + | Error (EventPredicates.Invalid_date s) -> Printf.eprintf "UID: %s Invalid date: %s\n" uid s + | Error Skip -> Printf.eprintf "UID: %s Skipped\n" uid) end let () = if !Sys.interactive then () else exit (CommandLine.main ical2rem) diff --git a/bin/remind.ml b/bin/remind.ml index cb85036..b35379d 100644 --- a/bin/remind.ml +++ b/bin/remind.ml @@ -1,519 +1,52 @@ -(* - FILE INTERAMENTE GENERATO DA LLM, DA RIVEDERE COMPLETAMENTE -*) - -(** Types for representing Remind events *) - -(** Weekday names in Remind format *) -type weekday = - | Monday - | Tuesday - | Wednesday - | Thursday - | Friday - | Saturday - | Sunday -[@@deriving show] - -(** Month names (Remind uses English month names) *) -type month = - | January - | February - | March - | April - | May - | June - | July - | August - | September - | October - | November - | December -[@@deriving show] - -type date_spec = { - day : int option; (** Day of month (1-31) *) - month : month option; (** Month *) - year : int option; (** Year (1990-2075) *) - weekdays : weekday list; (** List of weekdays for weekly recurrences *) -} -[@@deriving show] -(** Date specification in Remind *) - -type simple_date = { - year : int; - month : int; - day : int; -} -[@@deriving show] -(** Short-hand date format YYYY-MM-DD *) - -type time_spec = { - hour : int; (** 0-23 for 24h format, 1-12 for am/pm *) - minute : int; (** 0-59 *) -} -[@@deriving show] -(** Time specification (24-hour format or with AM/PM) *) - -(** Delta specification for advance warning *) -type delta = - | Plus of int (** +n - respects OMIT *) - | PlusPlus of int (** ++n - ignores OMIT *) -[@@deriving show] - -(** Back specification for backward scanning *) -type back = - | Minus of int (** -n - respects OMIT *) - | MinusMinus of int (** --n - ignores OMIT *) - | Tilde of int (** ~n - "lastworkday" style *) - | TildeTilde of int (** ~~n - "lastday" style *) -[@@deriving show] - -type repeat = int (* n - repeat every n days *) [@@deriving show] -(** Repeat specification for periodic reminders *) - -type tdelta = int [@@deriving show] -(** Time delta for timed reminders (in minutes) *) - -type trepeat = int [@@deriving show] -(** Time repeat for timed reminders (in minutes) *) - -(** Duration specification for timed events *) -type duration = - | Minutes of int (** Duration in minutes *) - | HoursMinutes of int * int (** Duration as hours:minutes *) -[@@deriving show] - -type priority = int [@@deriving show] -(** Priority (0-9999, default 5000) *) - -type omit = weekday list [@@deriving show] -(** OMIT specification - days to skip *) - -(** Special keywords *) -type modifier = - | Once (** ONCE - trigger only once per day *) - | Noqueue (** NOQUEUE - don't queue timed reminders *) -[@@deriving show] - -(** Action to take when reminder falls on an omitted day *) -type omit_action = - | Skip (** SKIP - skip the reminder completely *) - | Before (** BEFORE - move reminder to before omitted days *) - | After (** AFTER - move reminder to after omitted days *) -[@@deriving show] - -type trigger = { - date : date_spec option; (** Date specification *) - simple_date : simple_date option; (** Alternative: YYYY-MM-DD format *) - back : back option; (** Backward scanning *) - repeat : repeat option; (** Periodic repetition *) - delta : delta option; (** Advance warning *) - until : simple_date option; (** UNTIL expiry date *) - through : simple_date option; (** THROUGH (equivalent to *1 UNTIL) *) - from : simple_date option; (** FROM starting date *) - scanfrom : simple_date option; (** SCANFROM advanced starting date *) -} -[@@deriving show] -(** Trigger specification combining various time-related elements *) - -type timed = { - time : time_spec; - tdelta : tdelta option; - trepeat : trepeat option; -} -[@@deriving show] -(** Timed reminder specification *) - -type tag = string (* Up to 48 chars, no whitespace or comma *) [@@deriving show] -(** TAG specification for categorizing reminders *) - -type info = { - header : string; (** e.g., "Location", "Description", "Url" *) - value : string; -} -[@@deriving show] -(** INFO specification for metadata *) - -(** Body specification *) -type body = - | Msg of string (** MSG - simple message *) - | Msf of string (** MSF - formatted message *) - | Run of string (** RUN - execute command *) - | Cal of string (** CAL - calendar entry *) - | Satisfy of string (** SATISFY - conditional trigger expression *) - | Ps of string (** PS - PostScript *) - | Psfile of string (** PSFILE - PostScript file *) - | Special of string * string (** SPECIAL type body *) -[@@deriving show] +open Remind_sync +open Utils type rem = { - trigger : trigger; - timed : timed option; (** AT specification *) - priority : priority option; (** PRIORITY *) - omit : omit option; (** OMIT weekdays *) - omitfunc : string option; (** OMITFUNC function_name *) - addomit : bool; (** ADDOMIT flag *) - omit_action : omit_action option; (** SKIP/BEFORE/AFTER *) - modifiers : modifier list; (** ONCE, NOQUEUE, etc. *) - tags : tag list; (** TAG specifications *) - infos : info list; (** INFO specifications *) - duration : duration option; (** DURATION for timed events *) - todo : bool; (** TODO flag *) - complete_through : simple_date option; (** COMPLETE-THROUGH date for TODOs *) - max_overdue : int option; (** MAX-OVERDUE days for TODOs *) - warn : string option; (** WARN function name for precise scheduling *) - sched : string option; (** SCHED function name for timed reminders *) - tz : string option; (** TZ timezone *) - maybe_uncomputable : bool; (** MAYBE-UNCOMPUTABLE flag *) - body : body; (** MSG/RUN/etc. *) + original_uuid : string; (** Original UID from the iCalendar event *) + summary : string; (** Summary or title of the reminder *) + 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 *) + recurring : Icalendar.event list; + (** List of events that are part of the same recurring series: these are only the overrides, not the master event + *) } [@@deriving show] (** A complete REM command *) -type event = rem -(** Type alias for compatibility - a Remind event is a REM command *) - -(** Convenience constructors *) - -let make_simple_date year month day = { year; month; day } -let make_time hour minute = { hour; minute } -let make_date_spec ?day ?month ?year ?(weekdays = []) () = { day; month; year; weekdays } - -let make_trigger ?date ?simple_date ?back ?repeat ?delta ?until ?through ?from ?scanfrom () = - { date; simple_date; back; repeat; delta; until; through; from; scanfrom } - -let make_timed ?tdelta ?trepeat time = { time; tdelta; trepeat } -let make_info header value = { header; value } - -let make_rem ?(timed = None) ?(priority = None) ?(omit = None) ?(omitfunc = None) ?(addomit = false) - ?(omit_action = None) ?(modifiers = []) ?(tags = []) ?(infos = []) ?(duration = None) ?(todo = false) - ?(complete_through = None) ?(max_overdue = None) ?(warn = None) ?(sched = None) ?(tz = None) - ?(maybe_uncomputable = false) trigger body = +let empty = { - trigger; - timed; - priority; - omit; - omitfunc; - addomit; - omit_action; - modifiers; - tags; - infos; - duration; - todo; - complete_through; - max_overdue; - warn; - sched; - tz; - maybe_uncomputable; - body; + original_uuid = ""; + summary = ""; + date = Timedesc.Date.Ymd.make_exn ~year:1970 ~month:1 ~day:1; + end_date = None; + time = None; + duration = None; + recurring = []; } -(** Create a minimal default event - useful as a placeholder *) -let make_default_event msg = - let trigger = make_trigger () in - make_rem trigger (Msg msg) - -(** Helper to escape quotes in strings for INFO values *) -let escape_quotes s = - let buf = Buffer.create (String.length s) in - String.iter (fun c -> if c = '"' then Buffer.add_string buf "\\\"" else Buffer.add_char buf c) s; - Buffer.contents buf - -(** Convert types to Remind syntax strings *) - -let weekday_to_string = function - | Monday -> "Mon" - | Tuesday -> "Tue" - | Wednesday -> "Wed" - | Thursday -> "Thu" - | Friday -> "Fri" - | Saturday -> "Sat" - | Sunday -> "Sun" - -let month_to_string = function - | January -> "Jan" - | February -> "Feb" - | March -> "Mar" - | April -> "Apr" - | May -> "May" - | June -> "Jun" - | July -> "Jul" - | August -> "Aug" - | September -> "Sep" - | October -> "Oct" - | November -> "Nov" - | December -> "Dec" - -let simple_date_to_string d = Printf.sprintf "%04d-%02d-%02d" d.year d.month d.day -let time_to_string t = Printf.sprintf "%02d:%02d" t.hour t.minute - -let duration_to_string = function - | Minutes m -> string_of_int m - | HoursMinutes (h, m) -> Printf.sprintf "%d:%02d" h m - -let delta_to_string = function - | Plus n -> Printf.sprintf "+%d" n - | PlusPlus n -> Printf.sprintf "++%d" n - -let back_to_string = function - | Minus n -> Printf.sprintf "-%d" n - | MinusMinus n -> Printf.sprintf "--%d" n - | Tilde n -> Printf.sprintf "~%d" n - | TildeTilde n -> Printf.sprintf "~~%d" n - -let repeat_to_string r = Printf.sprintf "*%d" r - -let omit_action_to_string = function - | Skip -> "SKIP" - | Before -> "BEFORE" - | After -> "AFTER" - -(** Convert a REM to a string suitable for a .rem file *) -let rem_to_string rem = - let buf = Buffer.create 256 in - Buffer.add_string buf "REM"; - - (* MAYBE-UNCOMPUTABLE *) - if rem.maybe_uncomputable then Buffer.add_string buf " MAYBE-UNCOMPUTABLE"; - - (* TODO *) - if rem.todo then Buffer.add_string buf " TODO"; - - (* Date/trigger specification *) - (match rem.trigger.simple_date with - | Some sd -> - Buffer.add_char buf ' '; - Buffer.add_string buf (simple_date_to_string sd) - | None -> ( - match rem.trigger.date with - | Some ds -> ( - (* Weekdays *) - List.iter - (fun wd -> - Buffer.add_char buf ' '; - Buffer.add_string buf (weekday_to_string wd)) - ds.weekdays; - (* Day *) - (match ds.day with - | Some d -> - Buffer.add_char buf ' '; - Buffer.add_string buf (string_of_int d) - | None -> ()); - (* Month *) - (match ds.month with - | Some m -> - Buffer.add_char buf ' '; - Buffer.add_string buf (month_to_string m) - | None -> ()); - (* Year *) - match ds.year with - | Some y -> - Buffer.add_char buf ' '; - Buffer.add_string buf (string_of_int y) - | None -> ()) - | None -> ())); - - (* Back *) - (match rem.trigger.back with - | Some b -> - Buffer.add_char buf ' '; - Buffer.add_string buf (back_to_string b) +let string_of_rem rem = + let b = Buffer.create 256 in + Buffer.add_string b "REM "; + Buffer.add_string b (spf "INFO \"UID: %s\" " rem.original_uuid); + Buffer.add_string b (Timedesc.Date.to_rfc3339 rem.date); + (match rem.time with + | Some time -> + Buffer.add_string b " AT "; + Buffer.add_string b (string_of_time time) | None -> ()); - - (* Repeat *) - (match rem.trigger.repeat with - | Some r -> - Buffer.add_char buf ' '; - Buffer.add_string buf (repeat_to_string r) - | None -> ()); - - (* Delta *) - (match rem.trigger.delta with - | Some d -> - Buffer.add_char buf ' '; - Buffer.add_string buf (delta_to_string d) - | None -> ()); - - (* FROM *) - (match rem.trigger.from with - | Some f -> - Buffer.add_string buf " FROM "; - Buffer.add_string buf (simple_date_to_string f) - | None -> ()); - - (* UNTIL *) - (match rem.trigger.until with - | Some u -> - Buffer.add_string buf " UNTIL "; - Buffer.add_string buf (simple_date_to_string u) - | None -> ()); - - (* THROUGH *) - (match rem.trigger.through with - | Some t -> - Buffer.add_string buf " THROUGH "; - Buffer.add_string buf (simple_date_to_string t) - | None -> ()); - - (* SCANFROM *) - (match rem.trigger.scanfrom with - | Some sf -> - Buffer.add_string buf " SCANFROM "; - Buffer.add_string buf (simple_date_to_string sf) - | None -> ()); - - (* AT (timed) *) - (match rem.timed with - | Some t -> ( - Buffer.add_string buf " AT "; - Buffer.add_string buf (time_to_string t.time); - (match t.tdelta with - | Some td -> - Buffer.add_char buf ' '; - Buffer.add_char buf '+'; - Buffer.add_string buf (string_of_int td) - | None -> ()); - match t.trepeat with - | Some tr -> - Buffer.add_string buf " *"; - Buffer.add_string buf (string_of_int tr) - | None -> ()) - | None -> ()); - - (* SCHED *) - (match rem.sched with - | Some s -> - Buffer.add_string buf " SCHED "; - Buffer.add_string buf s - | None -> ()); - - (* WARN *) - (match rem.warn with - | Some w -> - Buffer.add_string buf " WARN "; - Buffer.add_string buf w - | None -> ()); - - (* OMIT *) - (match rem.omit with - | Some weekdays when weekdays <> [] -> - Buffer.add_string buf " OMIT"; - List.iter - (fun wd -> - Buffer.add_char buf ' '; - Buffer.add_string buf (weekday_to_string wd)) - weekdays - | _ -> ()); - - (* OMITFUNC *) - (match rem.omitfunc with - | Some func -> - Buffer.add_string buf " OMITFUNC "; - Buffer.add_string buf func - | None -> ()); - - (* SKIP/BEFORE/AFTER *) - (match rem.omit_action with - | Some action -> - Buffer.add_char buf ' '; - Buffer.add_string buf (omit_action_to_string action) - | None -> ()); - - (* ADDOMIT *) - if rem.addomit then Buffer.add_string buf " ADDOMIT"; - - (* PRIORITY *) - (match rem.priority with - | Some p -> - Buffer.add_string buf " PRIORITY "; - Buffer.add_string buf (string_of_int p) - | None -> ()); - - (* Modifiers (ONCE, NOQUEUE) *) - List.iter - (fun modifier -> - match modifier with - | Once -> Buffer.add_string buf " ONCE" - | Noqueue -> Buffer.add_string buf " NOQUEUE") - rem.modifiers; - - (* DURATION *) (match rem.duration with - | Some d -> - Buffer.add_string buf " DURATION "; - Buffer.add_string buf (duration_to_string d) + | Some duration -> + Buffer.add_string b " DURATION "; + Buffer.add_string b (string_of_span duration); + Buffer.add_string b "" | None -> ()); - - (* COMPLETE-THROUGH *) - (match rem.complete_through with - | Some ct -> - Buffer.add_string buf " COMPLETE-THROUGH "; - Buffer.add_string buf (simple_date_to_string ct) + (match rem.end_date with + | Some end_date -> + Buffer.add_string b " THROUGH "; + Buffer.add_string b (Timedesc.Date.to_rfc3339 end_date) | None -> ()); - - (* MAX-OVERDUE *) - (match rem.max_overdue with - | Some mo -> - Buffer.add_string buf " MAX-OVERDUE "; - Buffer.add_string buf (string_of_int mo) - | None -> ()); - - (* TZ *) - (match rem.tz with - | Some tz -> - Buffer.add_string buf " TZ "; - Buffer.add_string buf tz - | None -> ()); - - (* TAGs *) - List.iter - (fun tag -> - Buffer.add_string buf " TAG "; - Buffer.add_string buf tag) - rem.tags; - - (* INFOs - with proper escaping *) - List.iter - (fun info -> - Buffer.add_string buf " INFO \""; - Buffer.add_string buf (escape_quotes info.header); - Buffer.add_string buf ": "; - Buffer.add_string buf (escape_quotes info.value); - Buffer.add_char buf '"') - rem.infos; - - (* Body *) - Buffer.add_char buf ' '; - (match rem.body with - | Msg msg -> - Buffer.add_string buf "MSG "; - Buffer.add_string buf msg - | Msf msf -> - Buffer.add_string buf "MSF "; - Buffer.add_string buf msf - | Run cmd -> - Buffer.add_string buf "RUN "; - Buffer.add_string buf cmd - | Cal cal -> - Buffer.add_string buf "CAL "; - Buffer.add_string buf cal - | Satisfy expr -> - Buffer.add_string buf "SATISFY "; - Buffer.add_string buf expr - | Ps ps -> - Buffer.add_string buf "PS "; - Buffer.add_string buf ps - | Psfile file -> - Buffer.add_string buf "PSFILE "; - Buffer.add_string buf file - | Special (typ, body) -> - Buffer.add_string buf "SPECIAL "; - Buffer.add_string buf typ; - Buffer.add_char buf ' '; - Buffer.add_string buf body); - - Buffer.contents buf + Buffer.add_string b " MSG "; + Buffer.add_string b rem.summary; + Buffer.contents b diff --git a/bin/utils.ml b/bin/utils.ml index d4f0779..9ab59d8 100644 --- a/bin/utils.ml +++ b/bin/utils.ml @@ -1,36 +1,74 @@ +open Remind_sync open Icalendar +let spf = Printf.sprintf + let get_uid ev = let _, uid = ev.uid in uid +(* Questa funzione serve solo da esempio per copia e incolla *) +let unpack_date_or_datetime (d_or_dt : Icalendar.date_or_datetime) = + match d_or_dt with + | `Datetime (`Local _ptime_ts) -> () + | `Datetime (`Utc _ts) -> () + | `Datetime (`With_tzid (_ts, (_b, _tz_name))) -> () + | `Date (_year, _month, _day) -> () + +(* Questa funzione serve solo da esempio per copia e incolla *) +let unpack_dtend_or_duration dtend_or_dur = + match dtend_or_dur with + | None -> () + | Some (`Dtend (_, date_or_datetime)) -> unpack_date_or_datetime date_or_datetime + | Some (`Duration (_, _duration)) -> () + +let string_of_time (t : Timedesc.Time.t) : string = + let view = Timedesc.Time.view t in + let hour, minute = (view.Timedesc.Time.hour, view.Timedesc.Time.minute) in + spf "%02d:%02d" hour minute + +let string_of_span (sp : Timedesc.Span.t) : string = + let view = Timedesc.Span.For_human.view sp in + let hours, minutes = (view.Timedesc.Span.For_human.hours, view.Timedesc.Span.For_human.minutes) in + spf "%02d:%02d" hours minutes + +let timedesc_of_timestamp (ts : timestamp) : Timedesc.t = + let local_tz = Timedesc.Time_zone.local_exn () in + match ts with + | `Local t -> t |> Timedesc.Utils.timestamp_of_ptime |> Timedesc.of_timestamp_exn ~tz_of_date_time:local_tz + (* this case is not present in my current dataset… *) + | `Utc t -> t |> Timedesc.Utils.timestamp_of_ptime |> Timedesc.of_timestamp_exn ~tz_of_date_time:local_tz + | `With_tzid (ts, (_b, tz_name)) -> + (* Qui il timestamp è SCRITTO come se fosse UTC (+00:00) ma in realtà va interpretato con + il fuso orario indicato da tz_name. *) + let tz = Timedesc.Time_zone.make_exn tz_name in + let wrong_ts = Timedesc.Utils.timestamp_of_ptime ts in + let date = Timedesc.date (Timedesc.of_timestamp_exn ~tz_of_date_time:Timedesc.Time_zone.utc wrong_ts) in + let year, month, day = (Timedesc.Date.year date, Timedesc.Date.month date, Timedesc.Date.day date) in + let time = Timedesc.time_view (Timedesc.of_timestamp_exn ~tz_of_date_time:Timedesc.Time_zone.utc wrong_ts) in + let hour, minute, second = (time.Timedesc.Time.hour, time.Timedesc.Time.minute, time.Timedesc.Time.second) in + Timedesc.make_exn ~year ~month ~day ~hour ~minute ~second ~tz () + let timedesc_of_date_or_datetime (t : date_or_datetime) : Timedesc.t = match t with | `Datetime (`Local _ptime_ts) -> - (* TODO: this case is not present in my current dataset… *) - failwith "Unhandled case: `Local datetime" + (* this case is not present in my current dataset… *) + failwith "Unhandled case: `Local datetime" | `Datetime (`Utc ts) -> - Timedesc.Utils.timestamp_of_ptime ts |> Timedesc.of_timestamp_exn ~tz_of_date_time:(Timedesc.Time_zone.local_exn ()) + Timedesc.Utils.timestamp_of_ptime ts + |> Timedesc.of_timestamp_exn ~tz_of_date_time:(Timedesc.Time_zone.local_exn ()) | `Datetime (`With_tzid (ts, (_b, tz_name))) -> - (* Qui il timestamp è SCRITTO come se fosse UTC (+00:00) ma in realtà va interpretato con + (* Qui il timestamp è SCRITTO come se fosse UTC (+00:00) ma in realtà va interpretato con il fuso orario indicato da tz_name. *) - let tz = Timedesc.Time_zone.make_exn tz_name in - let wrong_ts = Timedesc.Utils.timestamp_of_ptime ts in - let date = Timedesc.date (Timedesc.of_timestamp_exn ~tz_of_date_time:Timedesc.Time_zone.utc wrong_ts) in - let year, month, day = (Timedesc.Date.year date, Timedesc.Date.month date, Timedesc.Date.day date) in - let time = Timedesc.time_view (Timedesc.of_timestamp_exn ~tz_of_date_time:Timedesc.Time_zone.utc wrong_ts) in - let hour, minute, second = (time.Timedesc.Time.hour, time.Timedesc.Time.minute, time.Timedesc.Time.second) in - Timedesc.make_exn ~year ~month ~day ~hour ~minute ~second ~tz () + let tz = Timedesc.Time_zone.make_exn tz_name in + let wrong_ts = Timedesc.Utils.timestamp_of_ptime ts in + let date = Timedesc.date (Timedesc.of_timestamp_exn ~tz_of_date_time:Timedesc.Time_zone.utc wrong_ts) in + let year, month, day = (Timedesc.Date.year date, Timedesc.Date.month date, Timedesc.Date.day date) in + let time = Timedesc.time_view (Timedesc.of_timestamp_exn ~tz_of_date_time:Timedesc.Time_zone.utc wrong_ts) in + let hour, minute, second = (time.Timedesc.Time.hour, time.Timedesc.Time.minute, time.Timedesc.Time.second) in + Timedesc.make_exn ~year ~month ~day ~hour ~minute ~second ~tz () | `Date (year, month, day) -> - Timedesc.make_exn ~year ~month ~day ~hour:0 ~minute:0 ~second:0 ~tz:(Timedesc.Time_zone.local_exn ()) () - -let get_y_m_d_from_timedesc (t : Timedesc.t) : int * int * int = - let date = Timedesc.date t in - (Timedesc.Date.year date, Timedesc.Date.month date, Timedesc.Date.day date) - -let get_start ev = - let _, start = ev.dtstart in - timedesc_of_date_or_datetime start + Timedesc.make_exn ~year ~month ~day ~hour:0 ~minute:0 ~second:0 ~tz:(Timedesc.Time_zone.local_exn ()) () let get_exdates ev = let event_props = ev.props in @@ -67,8 +105,32 @@ let get_rdates ev = | `Datetimes ts_list -> List.map (fun ts -> `Datetime ts) ts_list | `Dates date_list -> List.map (fun date -> `Date date) date_list | `Periods _ -> - (* TODO: Ignored for now, does not appear in my current dataset *) - failwith "Unhandled case: `Periods in RDATE" + (* Ignored for now, does not appear in my current dataset *) + failwith "Unhandled case: `Periods in RDATE" in added @ acc) |> List.map timedesc_of_date_or_datetime + +let get_recurrence_id ev = + List.find_map + (fun prop -> + match prop with + | `Recur_id (_, date_or_datetime) -> Some date_or_datetime + | _ -> None) + ev.props + +let separate_master_and_recurrence (events : Icalendar.event list) : Icalendar.event * Icalendar.event list = + (* List.iteri (fun i e -> Printf.eprintf "%02d: %s\n" (i + 1) (Icalendar.show_component (`Event e))) events; *) + let recur_ids = List.map (fun ev -> (ev, get_recurrence_id ev)) events in + + let master_and_recurrences = + List.partition_map + (fun (ev, recur_id_opt) -> + match recur_id_opt with + | None -> Right ev + | Some _ -> Left ev) + recur_ids + in + match master_and_recurrences with + | [], _ -> failwith "No master event found" + | master :: _, recurrences -> (master, recurrences) diff --git a/dune b/dune index f8837a3..3e55565 100644 --- a/dune +++ b/dune @@ -1 +1 @@ -(data_only_dirs contrib) +(data_only_dirs contrib calendars) diff --git a/lib/dune b/lib/dune index 53fe938..ffc81ba 100644 --- a/lib/dune +++ b/lib/dune @@ -1,2 +1,8 @@ (library - (name remind_sync)) + (name remind_sync) + (modules remind_sync timedesc_augmented result_augmented utf8 icalendar_augmented ptime_augmented) + (preprocess + (pps ppx_deriving.show)) + (libraries base logs timedesc uuseg uutf icalendar ptime)) + + diff --git a/lib/icalendar_augmented.ml b/lib/icalendar_augmented.ml new file mode 100644 index 0000000..f5cabce --- /dev/null +++ b/lib/icalendar_augmented.ml @@ -0,0 +1,316 @@ +module Params = struct + include Icalendar.Params + + let pp ppf _m = Format.pp_print_string ppf "" +end + +type params = Params.t [@@deriving show] + +module Ptime = struct + include Ptime_augmented +end + +(* TODO: tag these with `Utc | `Local *) +type timestamp_utc = Ptime.t [@@deriving show] +type timestamp_local = Ptime.t [@@deriving show] +type utc_or_timestamp_local = [ `Utc of timestamp_utc | `Local of timestamp_local ] [@@deriving show] +type timestamp = [ utc_or_timestamp_local | `With_tzid of timestamp_local * (bool * string) ] [@@deriving show] +type date_or_datetime = [ `Datetime of timestamp | `Date of Ptime.date ] [@@deriving show] +type weekday = [ `Friday | `Monday | `Saturday | `Sunday | `Thursday | `Tuesday | `Wednesday ] [@@deriving show] + +type recur = + [ `Byminute of int list + | `Byday of (int * weekday) list + | `Byhour of int list + | `Bymonth of int list + | `Bymonthday of int list + | `Bysecond of int list + | `Bysetposday of int list + | `Byweek of int list + | `Byyearday of int list + | `Weekday of weekday ] +[@@deriving show] + +type freq = [ `Daily | `Hourly | `Minutely | `Monthly | `Secondly | `Weekly | `Yearly ] [@@deriving show] +type count_or_until = [ `Count of int | `Until of utc_or_timestamp_local (* TODO date or datetime *) ] [@@deriving show] +type interval = int [@@deriving show] +type recurrence = freq * count_or_until option * interval option * recur list [@@deriving show] + +type valuetype = + [ `Binary + | `Boolean + | `Caladdress + | `Date + | `Datetime + | `Duration + | `Float + | `Integer + | `Period + | `Recur + | `Text + | `Time + | `Uri + | `Utcoffset + | `Xname of string * string + | `Ianatoken of string ] + +type cutype = [ `Group | `Individual | `Resource | `Room | `Unknown | `Ianatoken of string | `Xname of string * string ] +[@@deriving show] + +type partstat = + [ `Accepted + | `Completed + | `Declined + | `Delegated + | `In_process + | `Needs_action + | `Tentative + | `Ianatoken of string + | `Xname of string * string ] +[@@deriving show] + +type role = + [ `Chair | `Nonparticipant | `Optparticipant | `Reqparticipant | `Ianatoken of string | `Xname of string * string ] +[@@deriving show] + +type relationship = [ `Parent | `Child | `Sibling | `Ianatoken of string | `Xname of string * string ] [@@deriving show] + +type fbtype = [ `Free | `Busy | `Busy_Unavailable | `Busy_Tentative | `Ianatoken of string | `Xname of string * string ] +[@@deriving show] + +type param_value = [ `Quoted of string | `String of string ] [@@deriving show] + +type _ icalparameter = + | Altrep : Uri.t icalparameter + | Cn : param_value icalparameter + | Cutype : cutype icalparameter + | Delegated_from : Uri.t list icalparameter + | Delegated_to : Uri.t list icalparameter + | Dir : Uri.t icalparameter + | Encoding : [ `Base64 ] icalparameter + | Media_type : (string * string) icalparameter + | Fbtype : fbtype icalparameter + | Language : string icalparameter + | Member : Uri.t list icalparameter + | Partstat : partstat icalparameter + | Range : [ `Thisandfuture ] icalparameter + | Related : [ `Start | `End ] icalparameter + | Reltype : relationship icalparameter + | Role : role icalparameter + | Rsvp : bool icalparameter + | Sentby : Uri.t icalparameter + | Tzid : (bool * string) icalparameter + | Valuetype : valuetype icalparameter + | Iana_param : string -> param_value list icalparameter + | Xparam : (string * string) -> param_value list icalparameter +[@@deriving show] + +type other_prop = [ `Iana_prop of string * params * string | `Xprop of (string * string) * params * string ] +[@@deriving show] + +type cal_prop = + [ `Prodid of params * string + | `Version of params * string + | `Calscale of params * string + | `Method of params * string + | other_prop ] +[@@deriving show] + +type class_ = [ `Public | `Private | `Confidential | `Ianatoken of string | `Xname of string * string ] +[@@deriving show] + +type status = + [ `Draft + | `Final + | `Cancelled + | `Needs_action + | `Completed + | `In_process + | (* `Cancelled *) + `Tentative + | `Confirmed (* | `Cancelled *) ] +[@@deriving show] + +type period = timestamp * Ptime.Span.t * bool [@@deriving show] +type period_utc = timestamp_utc * Ptime.Span.t * bool [@@deriving show] +type dates_or_datetimes = [ `Datetimes of timestamp list | `Dates of Ptime.date list ] [@@deriving show] +type dates_or_datetimes_or_periods = [ dates_or_datetimes | `Periods of period list ] [@@deriving show] + +type general_prop = + [ `Dtstamp of params * timestamp_utc + | `Uid of params * string + | `Dtstart of params * date_or_datetime + | `Class of params * class_ + | `Created of params * timestamp_utc + | `Description of params * string + | `Geo of params * (float * float) + | `Lastmod of params * timestamp_utc + | `Location of params * string + | `Organizer of params * Uri.t + | `Priority of params * int + | `Seq of params * int + | `Status of params * status + | `Summary of params * string + | `Url of params * Uri.t + | `Recur_id of params * date_or_datetime + | (* TODO: Furthermore, this property MUST be specified + as a date with local time if and only if the "DTSTART" property + contained within the recurring component is specified as a date + with local time. *) + `Rrule of params * recurrence + | `Duration of params * Ptime.Span.t + | `Attach of params * [ `Uri of Uri.t | `Binary of string ] + | `Attendee of params * Uri.t + | `Categories of params * string list + | `Comment of params * string + | `Contact of params * string + | `Exdate of params * dates_or_datetimes + | `Rstatus of params * ((int * int * int option) * string * string option) + | `Related of params * string + | `Resource of params * string list + | `Rdate of params * dates_or_datetimes_or_periods ] +[@@deriving show] + +type event_prop = + [ general_prop + | `Transparency of params * [ `Transparent | `Opaque ] + | `Dtend of params * date_or_datetime + | (* TODO: valuetype same as DTSTART *) + other_prop ] +[@@deriving show] + +type 'a alarm_struct = { + trigger : params * [ `Duration of Ptime.Span.t | `Datetime of timestamp_utc ]; + duration_repeat : ((params * Ptime.Span.t) * (params * int)) option; + summary : (params * string) option; + other : other_prop list; + special : 'a; +} +[@@deriving show] + +type audio_struct = { attach : (params * [ `Uri of Uri.t | `Binary of string ]) option } [@@deriving show] +type display_struct = { description : (params * string) option } [@@deriving show] + +type email_struct = { + description : params * string; + attendees : (params * Uri.t) list; + attach : (params * [ `Uri of Uri.t | `Binary of string ]) option; +} +[@@deriving show] + +type alarm = + [ `Audio of audio_struct alarm_struct + | `Display of display_struct alarm_struct + | `Email of email_struct alarm_struct + | `None of unit alarm_struct ] +[@@deriving show] + +type tz_prop = + [ `Dtstart_local of params * timestamp_local + | `Tzoffset_to of params * Ptime.Span.t + | `Tzoffset_from of params * Ptime.Span.t + | `Rrule of params * recurrence + | `Comment of params * string + | `Rdate of params * dates_or_datetimes_or_periods + | `Tzname of params * string + | other_prop ] +[@@deriving show] + +type timezone_prop = + [ `Timezone_id of params * (bool * string) + | `Lastmod of params * timestamp_utc + | `Tzurl of params * Uri.t + | `Standard of tz_prop list + | `Daylight of tz_prop list + | other_prop ] +[@@deriving show] + +type todo_prop = + [ general_prop + | `Completed of params * timestamp_utc + | `Percent of params * int + | `Due of params * date_or_datetime + | other_prop ] +[@@deriving show] + +type journal_prop = [ general_prop | other_prop ] [@@deriving show] + +type freebusy_prop = + [ `Dtstamp of params * timestamp_utc + | `Uid of params * string + | `Contact of params * string + | `Dtstart_utc of params * timestamp_utc + | `Dtend_utc of params * timestamp_utc + | `Organizer of params * Uri.t + | `Url of params * Uri.t + | `Attendee of params * Uri.t + | `Comment of params * string + | `Freebusy of params * period_utc list + | `Rstatus of params * ((int * int * int option) * string * string option) + | other_prop ] +[@@deriving show] + +type event = { + dtstamp : params * timestamp_utc; + uid : params * string; + dtstart : params * date_or_datetime; (* NOTE: optional if METHOD present according to RFC 5545 *) + dtend_or_duration : [ `Duration of params * Ptime.Span.t | `Dtend of params * date_or_datetime ] option; + rrule : (params * recurrence) option; (* NOTE: RFC says SHOULD NOT occur more than once *) + props : event_prop list; + alarms : alarm list; +} +[@@deriving show] + +type timezone = timezone_prop list [@@deriving show] + +type component = + [ `Event of event + | `Todo of todo_prop list * alarm list + | `Journal of journal_prop list + | `Freebusy of freebusy_prop list + | `Timezone of timezone ] +[@@deriving show] + +let conv_alarm_struct (f : 'a -> 'b) (s : 'a Icalendar.alarm_struct) : 'b alarm_struct = + { + trigger = s.trigger; + duration_repeat = s.duration_repeat; + summary = s.summary; + other = s.other; + special = f s.special; + } + +let conv_audio_struct (s : Icalendar.audio_struct) : audio_struct = { attach = s.attach } +let conv_display_struct (s : Icalendar.display_struct) : display_struct = { description = s.description } + +let conv_email_struct (s : Icalendar.email_struct) : email_struct = + { description = s.description; attendees = s.attendees; attach = s.attach } + +let conv_alarm (a : Icalendar.alarm) : alarm = + match a with + | `Audio s -> `Audio (conv_alarm_struct conv_audio_struct s) + | `Display s -> `Display (conv_alarm_struct conv_display_struct s) + | `Email s -> `Email (conv_alarm_struct conv_email_struct s) + | `None s -> `None (conv_alarm_struct Fun.id s) + +let conv_event (e : Icalendar.event) : event = + { + dtstamp = e.dtstamp; + uid = e.uid; + dtstart = e.dtstart; + dtend_or_duration = e.dtend_or_duration; + rrule = e.rrule; + props = e.props; + alarms = List.map conv_alarm e.alarms; + } + +let conv_component (c : Icalendar.component) : component = + match c with + | `Event e -> `Event (conv_event e) + | `Todo (props, alms) -> `Todo (props, List.map conv_alarm alms) + | `Journal props -> `Journal props + | `Freebusy props -> `Freebusy props + | `Timezone tz -> `Timezone tz + +let parse s = + Result.map (fun (cal_props, components) -> (cal_props, List.map conv_component components)) (Icalendar.parse s) diff --git a/lib/ptime_augmented.ml b/lib/ptime_augmented.ml new file mode 100644 index 0000000..9dbc20c --- /dev/null +++ b/lib/ptime_augmented.ml @@ -0,0 +1,3 @@ +include Ptime + +type date = int * int * int [@@deriving show] diff --git a/lib/remind_sync.ml b/lib/remind_sync.ml new file mode 100644 index 0000000..0710b21 --- /dev/null +++ b/lib/remind_sync.ml @@ -0,0 +1,5 @@ +module Icalendar = Icalendar_augmented +module Ptime = Ptime_augmented +module Result = Result_augmented +module Timedesc = Timedesc_augmented +module Utf8 = Utf8 diff --git a/lib/result_augmented.ml b/lib/result_augmented.ml new file mode 100644 index 0000000..c2f4f92 --- /dev/null +++ b/lib/result_augmented.ml @@ -0,0 +1,42 @@ +module Internal_result = struct + type ('a, 'b) t = ('a, 'b) result = Ok of 'a | Error of 'b + + let return x = Ok x + let error e = Error e + let error_string s = Error (`Error_message s) + let bind = Stdlib.Result.bind + let ok = Result.ok + + module List = struct + let map (xs : 'a list) ~(f : 'a -> ('b, 'c) t) : ('b list, 'c) t = + let rec loop ?(acc = []) xs = + match xs with + | [] -> return (List.rev acc) + | hd :: tl -> ( + match f hd with + | Ok x -> loop ~acc:(x :: acc) tl + | Error e -> Error e) + in + loop xs + + let iteri ?(start = 0) (xs : 'a list) ~(f : int -> 'a -> (unit, 'b) t) : (unit, 'b) t = + let rec loop ?(idx = start) xs = + match xs with + | [] -> return () + | hd :: tl -> begin + let res = f idx hd in + match res with + | Ok () -> loop ~idx:(idx + 1) tl + | Error e -> Error e + end + in + loop xs + end + + module Let_syntax = struct + let ( let* ) = Stdlib.Result.bind + let ( let+ ) x f = Stdlib.Result.map f x + end +end + +include Internal_result diff --git a/lib/timedesc_augmented.ml b/lib/timedesc_augmented.ml new file mode 100644 index 0000000..6f71b46 --- /dev/null +++ b/lib/timedesc_augmented.ml @@ -0,0 +1,34 @@ +include Timedesc + +type t = Timedesc.t + +module Time = struct + include Timedesc.Time + + let pp = Timedesc.Time.pp_rfc3339 () +end + +module Span = struct + include Timedesc.Span +end + +module Date = struct + include Timedesc.Date + + type t = Timedesc.Date.t + + let pp = Timedesc.Date.pp_rfc3339 + + module Ymd = struct + include Timedesc.Date.Ymd + + type error = [ `Does_not_exist | `Invalid_year of int | `Invalid_month of int | `Invalid_day of int ] + [@@deriving show] + end +end + +module Timestamp = struct + type t = Timedesc.Timestamp.t + + let pp = Timedesc.Timestamp.pp +end diff --git a/lib/utf8.ml b/lib/utf8.ml new file mode 100644 index 0000000..4daf58f --- /dev/null +++ b/lib/utf8.ml @@ -0,0 +1,202 @@ +let length = Uuseg_string.fold_utf_8 `Grapheme_cluster (fun x _ -> x + 1) 0 + +let capitalize s = + let dec = Uutf.decoder ~encoding:`UTF_8 (`String s) in + + let rec split_loop ?(acc = []) () = + match Uutf.decode dec with + | `Await -> assert false + | `End -> List.rev acc + | `Malformed _ignored -> split_loop ~acc () + | `Uchar c -> split_loop ~acc:(c :: acc) () + in + + let buf = Buffer.create 1024 in + let enc = Uutf.encoder `UTF_8 (`Buffer buf) in + let rec capital_loop ?(last_was_upper = false) xs = + match xs with + | c :: tl -> + let last_was_upper = + if Uucp.Alpha.is_alphabetic c + then begin + let f = if last_was_upper = false then Uucp.Case.Map.to_upper else Uucp.Case.Map.to_lower in + match f c with + | `Self -> + let () = Uutf.encode enc (`Uchar c) |> ignore in + true + | `Uchars u_lst -> + List.iter (fun u -> Uutf.encode enc (`Uchar u) |> ignore) u_lst; + true + end + else + let () = Uutf.encode enc (`Uchar c) |> ignore in + false + in + capital_loop ~last_was_upper tl + | [] -> + let () = Uutf.encode enc `End |> ignore in + Buffer.contents buf + in + split_loop () |> capital_loop + +let lowercase s = + let dec = Uutf.decoder ~encoding:`UTF_8 (`String s) in + + let rec split_loop ?(acc = []) () = + match Uutf.decode dec with + | `Await -> assert false + | `End -> List.rev acc + | `Malformed _ignored -> split_loop ~acc () + | `Uchar c -> split_loop ~acc:(c :: acc) () + in + + let buf = Buffer.create 1024 in + let enc = Uutf.encoder `UTF_8 (`Buffer buf) in + let rec to_lower xs = + match xs with + | c :: tl -> + if Uucp.Alpha.is_alphabetic c + then begin + match Uucp.Case.Map.to_lower c with + | `Self -> + let () = Uutf.encode enc (`Uchar c) |> ignore in + to_lower tl + | `Uchars u_lst -> + List.iter (fun u -> Uutf.encode enc (`Uchar u) |> ignore) u_lst; + to_lower tl + end + else + let () = Uutf.encode enc (`Uchar c) |> ignore in + to_lower tl + | [] -> + let () = Uutf.encode enc `End |> ignore in + Buffer.contents buf + in + split_loop () |> to_lower + +let remove_non_alphabetic s = + let dec = Uutf.decoder ~encoding:`UTF_8 (`String s) in + + let rec split_loop ?(acc = []) () = + match Uutf.decode dec with + | `Await -> assert false + | `End -> List.rev acc + | `Malformed _ignored -> split_loop ~acc () + | `Uchar c -> split_loop ~acc:(c :: acc) () + in + + let buf = Buffer.create 1024 in + let enc = Uutf.encoder `UTF_8 (`Buffer buf) in + let rec filter_loop xs = + match xs with + | c :: tl -> + if Uucp.Alpha.is_alphabetic c + then begin + let () = Uutf.encode enc (`Uchar c) |> ignore in + filter_loop tl + end + else filter_loop tl + | [] -> + let () = Uutf.encode enc `End |> ignore in + Buffer.contents buf + in + split_loop () |> filter_loop + +let split_in_chunks_of n s = + let last, chunks = + Uuseg_string.fold_utf_8 + `Grapheme_cluster + (fun (last, chunks) grapheme -> + let l = List.length last in + if l < n + then (grapheme :: last, chunks) + else if l = n + then ([grapheme], (List.rev last |> StringLabels.concat ~sep:"") :: chunks) + else assert false) + ([], []) + s + in + (List.rev last |> StringLabels.concat ~sep:"") :: chunks |> List.rev + +let utf8_clamp_at n s = + let first = + Uuseg_string.fold_utf_8 + `Grapheme_cluster + (fun acc grapheme -> if List.length acc < n then grapheme :: acc else acc) + [] + s + in + let first = String.concat "" (List.rev first) in + let l = String.length first in + let rest = String.sub s l (String.length s - l) in + (first, rest) + +let clamp_at_space_up_to n s = + let module S = StringLabels in + let module L = ListLabels in + let words = S.split_on_char ~sep:' ' s |> L.map ~f:S.trim |> L.filter ~f:(( <> ) "") in + + let words = + match words with + | first :: rest -> + let l_fst = length first in + if l_fst <= n + then first :: rest + else + (* Prima parola troppo lunga, forza lo split anche se non è sullo spazio *) + let fst, snd = utf8_clamp_at n first in + fst :: snd :: rest + | [] -> [] + in + + let rec loop acc words = + match words with + | hd :: tl -> + let l = length hd in + if l <= n + then loop (hd :: acc) tl + else + let words' = split_in_chunks_of n hd in + loop (L.rev words' @ acc) tl + | [] -> L.rev acc + in + let words = loop [] words in + + let rec loop ?(ok = []) ?(total_chars = 0) ?(total_words = 0) words = + match words with + | hd :: tl -> + let l = length hd in + if total_chars + total_words + l > n + then (L.rev ok |> S.concat ~sep:" ", S.concat ~sep:" " words) + else loop ~ok:(hd :: ok) ~total_chars:(total_chars + l) ~total_words:(total_words + 1) tl + | [] -> (L.rev ok |> S.concat ~sep:" ", "") + in + loop words + +let split_at_space_up_to n s = + let rec loop ?(acc = []) s = + let s', rest = clamp_at_space_up_to n s in + let acc = s' :: acc in + if rest = "" then List.rev acc else loop ~acc rest + in + loop s + +let recode_string ?(encoding = `UTF_8) src = + let dst = Buffer.create 4 in + let rec loop d e = + match Uutf.decode d with + | `Uchar _ as u -> + let (_ : [`Ok | `Partial]) = Uutf.encode e u in + loop d e + | `End -> + let (_ : [`Ok | `Partial]) = Uutf.encode e `End in + () + | `Malformed _ -> + let (_ : [`Ok | `Partial]) = Uutf.encode e (`Uchar Uutf.u_rep) in + loop d e + | `Await -> assert false + in + let d = Uutf.decoder ~nln:(`NLF (Uchar.of_int 10)) ~encoding (`String src) in + let e = Uutf.encoder `UTF_8 (`Buffer dst) in + let () = loop d e in + Buffer.contents dst