refactor: replace predicate-based event matching with collector pipeline
- Simplify `.ocamlformat` to use `default` profile with fewer overrides - Extract shared types and utilities into a `remind_sync` library (`icalendar_augmented`, `ptime_augmented`, `timedesc_augmented`, `result_augmented`, `utf8`) - Replace `eventTransformer.ml` and the predicate system in `eventPredicates.ml` with a sequential collector pipeline (`collect_uuid`, `collect_summary`, `collect_start_end_duration`, etc.) - Simplify `Remind.rem` to a flat record with `Timedesc` date/time fields and replace `rem_to_string` with a leaner `string_of_rem` - Add `separate_master_and_recurrence` and `get_recurrence_id` helpers to `utils.ml` - Wire `main.ml` to call `EventPredicates.remind_of_event` per UID group and print results directly - Remove `eventTransformer` module from `bin/dune` and enable the `remind_sync` library dependency
This commit is contained in:
16
.ocamlformat
16
.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
|
||||
|
||||
4
bin/dune
4
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
|
||||
|
||||
@@ -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 ->
|
||||
| `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 ->
|
||||
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
|
||||
| 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
|
||||
| _ -> None
|
||||
end
|
||||
| _ -> None
|
||||
| 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
|
||||
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 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 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
|
||||
|
||||
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
|
||||
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 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]
|
||||
let rem = { rem with Remind.duration = Some duration } in
|
||||
Ok rem
|
||||
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]
|
||||
| `Date (_year, _month, _day) -> skip
|
||||
end
|
||||
| None -> None
|
||||
| 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 all_predicates : (predicate * event_description) list =
|
||||
let expand_recurrence rem ev : (Remind.rem, error) result =
|
||||
if List.length rem.Remind.recurring > 0 then skip else Ok rem
|
||||
|
||||
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]
|
||||
|
||||
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]
|
||||
|
||||
QUESTE SONO **TUTTE** LE RRULE NEL MIO DATASET
|
||||
|
||||
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)
|
||||
|
||||
@@ -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
|
||||
39
bin/main.ml
39
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,9 +15,12 @@ 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 =
|
||||
let events_map : Icalendar.event list Map.t =
|
||||
ListLabels.fold_left ~init:Map.empty components ~f:(fun acc comp ->
|
||||
match comp with
|
||||
| `Event ev ->
|
||||
@@ -26,32 +29,16 @@ let ical2rem ical_file =
|
||||
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); *)
|
||||
|
||||
(* 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)
|
||||
|
||||
545
bin/remind.ml
545
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)
|
||||
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 -> ());
|
||||
(* 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)
|
||||
| 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
|
||||
|
||||
84
bin/utils.ml
84
bin/utils.ml
@@ -1,16 +1,62 @@
|
||||
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… *)
|
||||
(* 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
|
||||
il fuso orario indicato da tz_name. *)
|
||||
@@ -24,14 +70,6 @@ let timedesc_of_date_or_datetime (t : date_or_datetime) : Timedesc.t =
|
||||
| `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
|
||||
|
||||
let get_exdates ev =
|
||||
let event_props = ev.props in
|
||||
let dates_or_datetimes =
|
||||
@@ -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 *)
|
||||
(* 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)
|
||||
|
||||
8
lib/dune
8
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))
|
||||
|
||||
|
||||
|
||||
316
lib/icalendar_augmented.ml
Normal file
316
lib/icalendar_augmented.ml
Normal file
@@ -0,0 +1,316 @@
|
||||
module Params = struct
|
||||
include Icalendar.Params
|
||||
|
||||
let pp ppf _m = Format.pp_print_string ppf "<params>"
|
||||
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)
|
||||
3
lib/ptime_augmented.ml
Normal file
3
lib/ptime_augmented.ml
Normal file
@@ -0,0 +1,3 @@
|
||||
include Ptime
|
||||
|
||||
type date = int * int * int [@@deriving show]
|
||||
5
lib/remind_sync.ml
Normal file
5
lib/remind_sync.ml
Normal file
@@ -0,0 +1,5 @@
|
||||
module Icalendar = Icalendar_augmented
|
||||
module Ptime = Ptime_augmented
|
||||
module Result = Result_augmented
|
||||
module Timedesc = Timedesc_augmented
|
||||
module Utf8 = Utf8
|
||||
42
lib/result_augmented.ml
Normal file
42
lib/result_augmented.ml
Normal file
@@ -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
|
||||
34
lib/timedesc_augmented.ml
Normal file
34
lib/timedesc_augmented.ml
Normal file
@@ -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
|
||||
202
lib/utf8.ml
Normal file
202
lib/utf8.ml
Normal file
@@ -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
|
||||
Reference in New Issue
Block a user