From fce66c5c781a8c6008baa8d8835f555eaac86c28 Mon Sep 17 00:00:00 2001 From: Paolo Donadeo Date: Sun, 10 May 2026 01:49:05 +0200 Subject: [PATCH] refactor(predicates): return features instead of bool, add P00/P11 predicates - Change predicate return type from `bool` to `features list option` to carry extracted event data (Summary, Day_start, Multi_day) alongside match results - Add `features` type with Generic_feature_presence, Summary, Day_start, Multi_day variants - Add P00 (has_summary) and P11 (override_events) predicates - Remove large commented-out icalendar/ptime type definitions - Refactor main.ml to group events by UID using a Map - Add get_y_m_d_from_timedesc helper to Utils --- bin/eventPredicates.ml | 2186 +++------------------------------------ bin/eventTransformer.ml | 12 +- bin/main.ml | 49 +- bin/remind.ml | 4 + bin/utils.ml | 4 + 5 files changed, 174 insertions(+), 2081 deletions(-) diff --git a/bin/eventPredicates.ml b/bin/eventPredicates.ml index 9d3b239..a031247 100644 --- a/bin/eventPredicates.ml +++ b/bin/eventPredicates.ml @@ -1,2031 +1,15 @@ open Icalendar open Utils -(* -FILE: icalendar.ml --------------------- - -module Uri = struct - include Uri - let pp = pp_hum -end - -module Ptime = struct - include Ptime - let equal_date (y, m, d) (y', m', d') = y = y' && m = m' && d = d' - let pp_date fmt (y, m, d) = Fmt.pf fmt "%04d-%02d-%02d" y m d -end - -let positive = true - -type timestamp_utc = Ptime.t [@@deriving eq, show] -type timestamp_local = Ptime.t [@@deriving eq, show] - -type utc_or_timestamp_local = [ - | `Utc of timestamp_utc - | `Local of timestamp_local -] [@@deriving eq, show] - -type timestamp = [ - utc_or_timestamp_local - | `With_tzid of timestamp_local * (bool * string) -] [@@deriving eq, show] - -type date_or_datetime = [ `Datetime of timestamp | `Date of Ptime.date ] [@@deriving eq, show] - -type valuetype = [ - `Binary | `Boolean | `Caladdress | `Date | `Datetime | `Duration | `Float - | `Integer | `Period | `Recur | `Text | `Time | `Uri | `Utcoffset - | `Xname of (string * string) | `Ianatoken of string -] [@@deriving eq, show] - -type cutype = [ `Group | `Individual | `Resource | `Room | `Unknown - | `Ianatoken of string | `Xname of string * string ] [@@deriving eq, show] - -type partstat = [ `Accepted | `Completed | `Declined | `Delegated - | `In_process | `Needs_action | `Tentative - | `Ianatoken of string | `Xname of string * string ] [@@deriving eq, show] - -type relationship = - [ `Parent | `Child | `Sibling | - `Ianatoken of string | `Xname of string * string ] [@@deriving eq, show] - -type role = [ `Chair | `Nonparticipant | `Optparticipant | `Reqparticipant - | `Ianatoken of string | `Xname of string * string ] [@@deriving eq, show] - -type fbtype = [ `Free | `Busy | `Busy_Unavailable | `Busy_Tentative | `Ianatoken of string | `Xname of string * string ] [@@deriving eq, show] - -type param_value = [ `Quoted of string | `String of string ] [@@deriving eq, 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 - -let equal_icalparameter : type a. a icalparameter -> a -> a -> bool - = fun k lhs_v rhs_v -> - match k with - | Altrep -> Uri.equal lhs_v rhs_v - | Cn -> equal_param_value lhs_v rhs_v - | Cutype -> equal_cutype lhs_v rhs_v - | Delegated_from -> List.for_all2 Uri.equal lhs_v rhs_v - | Delegated_to -> List.for_all2 Uri.equal lhs_v rhs_v - | Dir -> Uri.equal lhs_v rhs_v - | Encoding -> lhs_v = rhs_v - | Media_type -> String.equal (fst lhs_v) (fst rhs_v) && String.equal (snd lhs_v) (snd rhs_v) - | Fbtype -> equal_fbtype lhs_v rhs_v - | Language -> String.equal lhs_v rhs_v - | Member -> List.for_all2 Uri.equal lhs_v rhs_v - | Partstat -> equal_partstat lhs_v rhs_v - | Range -> lhs_v = rhs_v - | Related -> lhs_v = rhs_v - | Reltype -> equal_relationship lhs_v rhs_v - | Role -> equal_role lhs_v rhs_v - | Rsvp -> lhs_v = rhs_v - | Sentby -> Uri.equal lhs_v rhs_v - | Tzid -> fst lhs_v = fst rhs_v && String.equal (snd lhs_v) (snd rhs_v) - | Valuetype -> equal_valuetype lhs_v rhs_v - | Iana_param _ -> List.for_all2 equal_param_value lhs_v rhs_v - | Xparam _ -> List.for_all2 equal_param_value lhs_v rhs_v - -let pp_icalparameter : type a. Format.formatter -> a icalparameter -> a -> unit - = fun fmt k v -> - match k with - | Altrep -> Format.fprintf fmt "Altrep %a" Uri.pp v - | Cn -> Format.fprintf fmt "Cn %a" pp_param_value v - | Cutype -> Format.fprintf fmt "Cutype %a" pp_cutype v - | Delegated_from -> Format.fprintf fmt "Delegated_from %a" Fmt.(list Uri.pp) v - | Delegated_to -> Format.fprintf fmt "Delegated_to %a" Fmt.(list Uri.pp) v - | Dir -> Format.fprintf fmt "Dir %a" Uri.pp v - | Encoding -> Format.fprintf fmt "Encoding base64" - | Media_type -> Format.fprintf fmt "Media_type (%s/%s)" (fst v) (snd v) - | Fbtype -> Format.fprintf fmt "Fbtype %a" pp_fbtype v - | Language -> Format.fprintf fmt "Language %s" v - | Member -> Format.fprintf fmt "Member %a" Fmt.(list Uri.pp) v - | Partstat -> Format.fprintf fmt "Partstat %a" pp_partstat v - | Range -> Format.fprintf fmt "Range thisandfuture" - | Related -> Format.fprintf fmt "Related %s" (match v with `Start -> "start" | `End -> "end") - | Reltype -> Format.fprintf fmt "Reltype %a" pp_relationship v - | Role -> Format.fprintf fmt "Role %a" pp_role v - | Rsvp -> Format.fprintf fmt "Rsvp %b" v - | Sentby -> Format.fprintf fmt "Sentby %a" Uri.pp v - | Tzid -> Format.fprintf fmt "Tzid (%b, %s)" (fst v) (snd v) - | Valuetype -> Format.fprintf fmt "Valuetype %a" pp_valuetype v - | Iana_param a -> Format.fprintf fmt "Iana_param (%s, %a)" a Fmt.(list pp_param_value) v - | Xparam (a, b) -> Format.fprintf fmt "Xparam ((%s, %s), %a)" a b Fmt.(list pp_param_value) v - -module K = struct - type 'a t = 'a icalparameter - - let compare : type a b. a t -> b t -> (a, b) Gmap.Order.t = fun lhs rhs -> - let open Gmap.Order in - match (lhs, rhs) with - | (Altrep, Altrep) -> Eq - | (Cn, Cn) -> Eq - | (Cutype, Cutype) -> Eq - | (Delegated_from, Delegated_from) -> Eq - | (Delegated_to, Delegated_to) -> Eq - | (Dir, Dir) -> Eq - | (Encoding, Encoding) -> Eq - | (Media_type, Media_type) -> Eq - | (Fbtype, Fbtype) -> Eq - | (Language, Language) -> Eq - | (Member, Member) -> Eq - | (Partstat, Partstat) -> Eq - | (Range, Range) -> Eq - | (Related, Related) -> Eq - | (Reltype, Reltype) -> Eq - | (Role, Role) -> Eq - | (Rsvp, Rsvp) -> Eq - | (Sentby, Sentby) -> Eq - | (Tzid, Tzid) -> Eq - | (Valuetype, Valuetype) -> Eq - | (Iana_param a, Iana_param a') -> - begin match String.compare a a' with - | 0 -> Eq - | x when x < 0 -> Lt - | _ -> Gt - end - | (Xparam (a, b), Xparam (a', b')) -> - begin match String.compare a a' with - | 0 -> - begin match String.compare b b' with - | 0 -> Eq - | y when y < 0 -> Lt - | _ -> Gt - end - | x when x < 0 -> Lt - | _ -> Gt - end - | _ -> - let to_int : type a. a icalparameter -> int = - function - | Altrep -> 0 - | Cn -> 1 - | Cutype -> 2 - | Delegated_from -> 3 - | Delegated_to -> 4 - | Dir -> 5 - | Encoding -> 6 - | Media_type -> 7 - | Fbtype -> 8 - | Language -> 9 - | Member -> 10 - | Partstat -> 11 - | Range -> 12 - | Related -> 13 - | Reltype -> 14 - | Role -> 15 - | Rsvp -> 16 - | Sentby -> 17 - | Tzid -> 18 - | Valuetype -> 19 - | Iana_param _ -> 20 - | Xparam _ -> 21 in - if Stdlib.compare (to_int lhs) (to_int rhs) < 0 - then Lt else Gt -end - -module Params = Gmap.Make(K) - -type params = Params.t - -let equal_params m m' = - Params.equal { f = equal_icalparameter } m m' - -let pp_params ppf m = Params.iter - (fun (Params.B (k, v)) -> - pp_icalparameter ppf k v ; - Format.pp_print_space ppf ()) m - -type other_prop = - [ `Iana_prop of string * params * string - | `Xprop of (string * string) * params * string ] [@@deriving eq, show] - -type cal_prop = - [ `Prodid of params * string - | `Version of params * string - | `Calscale of params * string - | `Method of params * string - | other_prop - ] [@@deriving eq, show] - -type weekday = [ `Friday | `Monday | `Saturday | `Sunday | `Thursday | `Tuesday | `Wednesday ] [@@deriving eq, 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 eq, show] - -type freq = [ `Daily | `Hourly | `Minutely | `Monthly | `Secondly | `Weekly | `Yearly ] [@@deriving eq, show] - -type count_or_until = [ - | `Count of int - | `Until of utc_or_timestamp_local -] [@@deriving eq, show] - -type interval = int [@@deriving eq, show] - -type recurrence = freq * count_or_until option * interval option * recur list [@@deriving eq, show] - -type class_ = [ `Public | `Private | `Confidential | `Ianatoken of string | `Xname of string * string ] [@@deriving eq, show] - -type status = [ `Draft | `Final | `Cancelled | - `Needs_action | `Completed | `In_process | `Tentative | `Confirmed ] [@@deriving eq, show] - -type period = timestamp * Ptime.Span.t * bool [@@deriving eq, show] -type period_utc = timestamp_utc * Ptime.Span.t * bool [@@deriving eq, show] - -type dates_or_datetimes = [ `Datetimes of timestamp list | `Dates of Ptime.date list ] [@@deriving eq, show] -type dates_or_datetimes_or_periods = [ dates_or_datetimes | `Periods of period list ] [@@deriving eq, 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 - | `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 eq, show] - -type event_prop = [ - | general_prop - | `Transparency of params * [ `Transparent | `Opaque ] - | `Dtend of params * date_or_datetime - | other_prop -] [@@deriving eq, 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 eq, show] - -type audio_struct = { - attach: (params * [ `Uri of Uri.t | `Binary of string ]) option ; -} [@@deriving eq, show] - -type display_struct = { - description : (params * string) option ; -} [@@deriving eq, show] - -type email_struct = { - description : params * string ; - attendees : (params * Uri.t) list ; - attach: (params * [ `Uri of Uri.t | `Binary of string ]) option ; -} [@@deriving eq, 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 eq, 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 eq, 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 eq, show] - -type todo_prop = [ - | general_prop - | `Completed of params * timestamp_utc - | `Percent of params * int - | `Due of params * date_or_datetime - | other_prop -] [@@deriving eq, show] - -type journal_prop = [ - | general_prop - | other_prop -] [@@deriving eq, 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 eq, show] - -type event = { - dtstamp : params * timestamp_utc ; - uid : params * string ; - dtstart : params * date_or_datetime ; - dtend_or_duration : [ `Duration of params * Ptime.Span.t | `Dtend of params * date_or_datetime ] option ; - rrule : (params * recurrence) option ; - props : event_prop list ; - alarms : alarm list ; -} [@@deriving eq, show] - -END OF FILE: icalendar.ml -*) - -(* -FILE: icalendar.mli --------------------- - -type timestamp_utc = Ptime.t [@@deriving eq, show] -type timestamp_local = Ptime.t [@@deriving eq, show] - -type utc_or_timestamp_local = [ - | `Utc of timestamp_utc - | `Local of timestamp_local -] [@@deriving eq, show] - -type timestamp = [ - utc_or_timestamp_local - | `With_tzid of timestamp_local * (bool * string) -] [@@deriving eq, show] - -type date_or_datetime = [ `Datetime of timestamp | `Date of Ptime.date ] - -type weekday = [ `Friday | `Monday | `Saturday | `Sunday | `Thursday | `Tuesday | `Wednesday ] [@@deriving eq, 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 eq, show] - -type freq = [ `Daily | `Hourly | `Minutely | `Monthly | `Secondly | `Weekly | `Yearly ] [@@deriving eq, show] - -type count_or_until = [ - | `Count of int - | `Until of utc_or_timestamp_local (* TODO date or datetime *) -] [@@deriving eq, show] - -type interval = int - -type recurrence = freq * count_or_until option * interval option * recur list [@@deriving eq, 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 ] - -type partstat = [ `Accepted | `Completed | `Declined | `Delegated - | `In_process | `Needs_action | `Tentative - | `Ianatoken of string | `Xname of string * string ] - -type role = [ `Chair | `Nonparticipant | `Optparticipant | `Reqparticipant - | `Ianatoken of string | `Xname of string * string ] - -type relationship = - [ `Parent | `Child | `Sibling | - `Ianatoken of string | `Xname of string * string ] - -type fbtype = [ `Free | `Busy | `Busy_Unavailable | `Busy_Tentative | `Ianatoken of string | `Xname of string * string ] [@@deriving eq, show] - -type param_value = [ `Quoted of string | `String of string ] - -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 - -module Params : sig include Gmap.S with type 'a key = 'a icalparameter end - -type params = Params.t - -type other_prop = - [ `Iana_prop of string * params * string - | `Xprop of (string * string) * params * string ] [@@deriving eq, show] - -type cal_prop = - [ `Prodid of params * string - | `Version of params * string - | `Calscale of params * string - | `Method of params * string - | other_prop - ] - -type class_ = [ `Public | `Private | `Confidential | `Ianatoken of string | `Xname of string * string ] - -type status = [ `Draft | `Final | `Cancelled | - `Needs_action | `Completed | `In_process | (* `Cancelled *) - `Tentative | `Confirmed (* | `Cancelled *) ] - -type period = timestamp * Ptime.Span.t * bool -type period_utc = timestamp_utc * Ptime.Span.t * bool - -type dates_or_datetimes = [ `Datetimes of timestamp list | `Dates of Ptime.date list ] -type dates_or_datetimes_or_periods = [ dates_or_datetimes | `Periods of period list ] - -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 -] - -type event_prop = [ - | general_prop - | `Transparency of params * [ `Transparent | `Opaque ] - | `Dtend of params * date_or_datetime - (* TODO: valuetype same as DTSTART *) - | other_prop -] - -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 ; -} - -type audio_struct = { - attach: (params * [ `Uri of Uri.t | `Binary of string ]) option ; -} - -type display_struct = { - description : (params * string) option ; -} - -type email_struct = { - description : params * string ; - attendees : (params * Uri.t) list ; - attach: (params * [ `Uri of Uri.t | `Binary of string ]) option ; -} - -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 -] - -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 -] - -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 -] - -type todo_prop = [ - | general_prop - | `Completed of params * timestamp_utc - | `Percent of params * int - | `Due of params * date_or_datetime - | other_prop -] - -type journal_prop = [ - | general_prop - | other_prop -] - -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 -] - -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 ; -} - -type timezone = timezone_prop list - -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] - -(* -val in_timerange : component -> (Ptime.t * bool) * (Ptime.t * bool) -> bool -*) -val component_to_ics_key : component -> string - -type calendar = cal_prop list * component list - -val parse_datetime: string -> (timestamp, string) result -val parse : string -> (calendar, string) result -val pp : calendar Fmt.t -val equal_calendar : calendar -> calendar -> bool - -(* TODO this actually belongs to CalDAV! this is Webdav_xml module! *) -type comp = [ `Allcomp | `Comp of component_transform list ] -and prop = [ `Allprop | `Prop of (string * bool) list ] -and component_transform = string * prop * comp [@@deriving show, eq] - -val to_ics : ?cr:bool -> ?filter:component_transform option -> calendar -> string - -module Writer : sig - val duration_to_ics : Ptime.Span.t -> Buffer.t -> unit - val cal_prop_to_ics_key : cal_prop -> string -end - -val recur_dates : Ptime.t -> recurrence -> (unit -> Ptime.t option) - -val recur_events : ?recurrence_ids:event list -> event -> (unit -> event option) - -val normalize_timezone : Ptime.t -> bool * String.t -> - timezone_prop list list -> - Ptime.t option - - -END OF FILE: icalendar.mli -*) - -(* -FILE: ptime.ml --------------------- -(*--------------------------------------------------------------------------- - Copyright (c) 2015 The ptime programmers. All rights reserved. - SPDX-License-Identifier: ISC - ---------------------------------------------------------------------------*) - -(* Julian day and proleptic Gregorian calendar date conversion. - - Formulae are from the calendar FAQ: - http://www.tondering.dk/claus/cal/julperiod.php#formula - - These formulae work for positive Julian days. They represent - Gegorian calendar BCE year `y` by `-(y-1)`, e.g. 2 BCE is -1, this - follows the convention of ISO 8601. - - All timestamps in Ptime's [min;max] range are represented by - positive Julian days and the formulae do not overflow on 32-bit - platforms in this restricted range. *) - -let jd_to_date jd = - let a = jd + 32044 in - let b = (4 * a + 3) / 146097 in - let c = a - ((146097 * b) / 4) in - let d = (4 * c + 3) / 1461 in - let e = c - ((1461 * d) / 4) in - let m = (5 * e + 2) / 153 in - let day = e - ((153 * m + 2) / 5) + 1 in - let month = m + 3 - (12 * (m / 10)) in - let year = 100 * b + d - 4800 + (m / 10) in - (year, month, day) - -let jd_to_year jd = (* Same as above but only for the year *) - let a = jd + 32044 in - let b = (4 * a + 3) / 146097 in - let c = a - ((146097 * b) / 4) in - let d = (4 * c + 3) / 1461 in - let e = c - ((1461 * d) / 4) in - let m = (5 * e + 2) / 153 in - 100 * b + d - 4800 + (m / 10) - -let jd_of_date (year, month, day) = - let a = (14 - month) / 12 in - let y = year + 4800 - a in - let m = month + 12 * a - 3 in - day + ((153 * m) + 2)/ 5 + 365 * y + - (y / 4) - (y / 100) + (y / 400) - 32045 - -let jd_posix_epoch = 2_440_588 (* the Julian day of the POSIX epoch *) -let jd_ptime_min = 1_721_060 (* the Julian day of Ptime.min *) -let jd_ptime_max = 5_373_484 (* the Julian day of Ptime.max *) - -(* Picosecond precision POSIX timestamps and time span representation. - - POSIX timestamps and spans are represented by int * int64 pairs - with the int64 in the range [0L;86_399_999_999_999_999L]. A pair - [(d, ps)] denotes the POSIX picosecond duration [d] * 86_400e12 + - [ps]. - - For a timestamp this can be seen as a POSIX day count from the - epoch paired with a picosecond precision POSIX time point in that - day starting from 00:00:00. - - By definition with a negative [d] the [ps] duration brings us - towards zero, *not* towards infinity: - - - (d * 86_400e12) (d * 86_400e12 + ps) 0 - ... -----+-----------------+-------------------+--------- ... - [---------------->| - ps - - [d] is largely sufficent to represent all the days in Ptime's - [min;max] range on both 32-bit and 64-bit platforms. *) - -type t = int * int64 - -let ps_count_in_ps = 1L -let ps_count_in_ns = 1_000L -let ps_count_in_100ns = 100_000L -let ps_count_in_us = 1_000_000L -let ps_count_in_100us = 100_000_000L -let ps_count_in_ms = 1_000_000_000L -let ps_count_in_100ms = 100_000_000_000L -let ps_count_in_s = 1_000_000_000_000L -let ps_count_in_min = 60_000_000_000_000L -let ps_count_in_hour = 3600_000_000_000_000L -let ps_count_in_day = 86_400_000_000_000_000L -let ps_day_max = 86_399_999_999_999_999L - -let day_min = jd_ptime_min - jd_posix_epoch -let day_max = jd_ptime_max - jd_posix_epoch - -let epoch = (0, 0L) (* 1970-01-01 00:00:00 UTC *) -let min = (day_min, 0L) (* 0000-01-01 00:00:00 UTC *) -let max = (day_max, ps_day_max) (* 9999-12-31 23:59:59 UTC *) - -(* POSIX time spans *) - -type span = t - -module Span = struct - - let stdlib_abs = abs - - (* Arithmetic *) - - let neg = function - | (d, 0L) -> (-d, 0L) - | (d, ps) -> (-(d + 1), Int64.sub ps_count_in_day ps) - - let add (d0, ps0) (d1, ps1) = - let d = d0 + d1 in - let ps = Int64.add ps0 ps1 in - let ps_clamp = Int64.rem ps ps_count_in_day in - let d = d + Int64.compare ps ps_clamp in - d, ps_clamp - - let sub s0 s1 = add s0 (neg s1) - let abs (d, _ as s) = if d < 0 then neg s else s - - (* POSIX time spans *) - - type t = span - - let zero = (0, 0L) - let v (d, ps as s) = - if ps < 0L || ps > ps_day_max - then invalid_arg (Format.sprintf "illegal ptime time span: (%d,%Ld)" d ps) - else s - - let of_d_ps (d, ps as s) = if ps < 0L || ps > ps_day_max then None else Some s - let unsafe_of_d_ps s = s - let unsafe_of_d_ps_option s = s - let to_d_ps s = s - - let of_int_s secs = - let d = stdlib_abs secs in - let s = (d / 86_400, Int64.(mul (of_int (d mod 86_400)) ps_count_in_s)) in - if secs < 0 then neg s else s - - let day_int_min = min_int / 86_400 - let day_int_max = max_int / 86_400 - let to_int_s (d, ps) = - if d < day_int_min || d > day_int_max then None else - let days_s = d * 86_400 in - let day_s = Int64.(to_int (div ps ps_count_in_s)) (* always positive *) in - let secs = days_s + day_s in - if secs < days_s (* positive overflow *) then None else Some secs - - let min_int_float = float min_int - let max_int_float = float max_int - let of_float_s secs = - if secs <> secs (* nan *) then None else - let days = floor (secs /. 86_400.) in - if days < min_int_float || days > max_int_float then None else - let rem_s = mod_float secs 86_400. in - let rem_s = if rem_s < 0. then 86_400. +. rem_s else rem_s in - if rem_s >= 86_400. then - (* Guard against a potential overflow in the computation of [rem_s] *) - let days = days +. 1. in - if days > max_int_float then None else - Some (int_of_float days, 0L) - else - let frac_s, rem_s = modf rem_s in - let rem_ps = Int64.(mul (of_float rem_s) ps_count_in_s) in - let frac_ps = Int64.(of_float (frac_s *. 1e12)) in - Some (int_of_float days, (Int64.add rem_ps frac_ps)) - - let to_float_s (d, ps) = - let days_s = (float d) *. 86_400. in - let day_s = Int64.(to_float (div ps ps_count_in_s)) in - let day_rem_ps = Int64.(to_float (rem ps ps_count_in_s)) in - days_s +. day_s +. (day_rem_ps *. 1e-12) - - (* Predicates *) - - let equal (d0, ps0) (d1, ps1) = - (compare : int -> int -> int) d0 d1 = 0 && - Int64.compare ps0 ps1 = 0 - - let compare (d0, ps0) (d1, ps1) = - let c = (compare : int -> int -> int) d0 d1 in - if c <> 0 then c else (compare : int64 -> int64 -> int) ps0 ps1 - - (* Rounding *) - - let round_div a b = (* a >= 0 and b > 0 *) - if a = 0L then 0L else - Int64.(div (add a (div b 2L)) b) - - let frac_div = [| 1_000_000_000_000L; - 100_000_000_000L; - 10_000_000_000L; - 1_000_000_000L; - 100_000_000L; - 10_000_000L; - 1_000_000L; - 100_000L; - 10_000L; - 1_000L; - 100L; - 10L; - 1L; |] - - let round ~frac_s:frac (sign, _ as t) = - let frac = if frac < 0 then 0 else (if frac > 12 then 12 else frac) in - let (d, ps) = if sign < 0 then neg t else t in - let rps = Int64.mul (round_div ps frac_div.(frac)) frac_div.(frac) in - let t = if rps > ps_day_max then (d + 1, 0L) else (d, rps) in - if sign < 0 then neg t else t - - let truncate ~frac_s:frac (sign, _ as t) = - let frac = if frac < 0 then 0 else (if frac > 12 then 12 else frac) in - let (d, ps) = if sign < 0 then neg t else t in - let tps = Int64.(sub ps (rem ps frac_div.(frac))) in - if sign < 0 then neg (d, tps) else (d, tps) - - let truncate_down ~frac_s:frac (d, ps) = - (d, Int64.(sub ps (rem ps frac_div.(frac )))) - - (* Pretty printing *) - - let dump ppf (d, ps) = Format.fprintf ppf "@[<1>(%d,@,%Ld)@]" d ps - - (* Warning laborious code follows. Is there a better way ? *) - - let divide_ps ~carry ps hi lo = - let hi_d = Int64.(to_int (div ps hi)) in - let rem_ps = Int64.rem ps hi in - let lo_d = Int64.to_int (round_div rem_ps lo) in - if lo_d = carry then hi_d + 1, 0 else hi_d, lo_d - - let pp_y_d ppf ~neg d ps = (* assert d >= 0 *) - let y, rem_d = - let max_d = max_int / 4 in - if d > max_d then (* d * 4 overflows *) d / 365, d mod 365 else - let y = (d * 4) / 1461 (* / 365.25 *) in - y, d - (y * 1461) / 4 - in - let days = rem_d + Int64.to_int (round_div ps ps_count_in_day) in - let y, days = if days = 366 then y + 1, 1 else y, days in - let y = if neg then -y else y in - Format.fprintf ppf "%dy" y; - if days <> 0 then Format.fprintf ppf "%dd" days; - () - - let pp_d_h ppf ~neg d ps = - let h, _ = divide_ps ~carry:1 ps ps_count_in_hour ps_count_in_hour in - let d, h = if h = 24 then d + 1, 0 else d, h in - if d = 366 then Format.fprintf ppf "%dy1d" (if neg then -1 else 1) else - if d = 365 && h >= 6 - then Format.fprintf ppf "%dy" (if neg then -1 else 1) else - let d = if neg then -d else d in - Format.fprintf ppf "%dd" d; - if h <> 0 then Format.fprintf ppf "%dh" h; - () - - let pp_h_m ppf ~neg ps = - let h, m = divide_ps ~carry:60 ps ps_count_in_hour ps_count_in_min in - if h = 24 then Format.fprintf ppf "%dd" (if neg then -1 else 1) else - let h = if neg then -h else h in - Format.fprintf ppf "%dh" h; - if m <> 0 then Format.fprintf ppf "%dmin" m; - () - - let pp_m_s ppf ~neg ps = - let m, s = divide_ps ~carry:60 ps ps_count_in_min ps_count_in_s in - if m = 60 then Format.fprintf ppf "%dh" (if neg then -1 else 1) else - let m = if neg then -m else m in - Format.fprintf ppf "%dmin" m; - if s <> 0 then Format.fprintf ppf "%ds" s; - () - - let pp_s ppf ~neg ps = - let s, ms = divide_ps ~carry:1000 ps ps_count_in_s ps_count_in_ms in - if s = 60 then Format.fprintf ppf "%dmin" (if neg then -1 else 1) else - let s = if neg then -s else s in - if ms <> 0 then Format.fprintf ppf "%d.%03ds" s ms else - Format.fprintf ppf "%ds" s - - let pp_unit higher_str hi hi_str frac_limit lo ppf ~neg ps = - let pp_unit_integral ppf ~neg h = - if h = 1000 - then Format.fprintf ppf "%d%s" (if neg then -1 else 1) higher_str - else Format.fprintf ppf "%d%s" (if neg then -h else h) hi_str - in - if ps < frac_limit then begin - let h, l = divide_ps ~carry:1000 ps hi lo in - if h >= 100 || l = 0 then pp_unit_integral ppf ~neg h else - let h = if neg then -h else h in - Format.fprintf ppf "%d.%03d%s" h l hi_str - end else begin - let ms, _ = divide_ps ~carry:1 ps hi hi in - pp_unit_integral ppf ~neg ms - end - - let pp_ms = - pp_unit "s" ps_count_in_ms "ms" ps_count_in_100ms ps_count_in_us - - let pp_us = - pp_unit "ms" ps_count_in_us "us" ps_count_in_100us ps_count_in_ns - - let pp_ns = - pp_unit "us" ps_count_in_ns "ns" ps_count_in_100ns ps_count_in_ps - - let pp_ps ppf ~neg ps = - let ps = Int64.to_int ps in - Format.fprintf ppf "%dps" (if neg then -ps else ps) - - let pp ppf (sign, _ as s) = - let neg = sign < 0 in - match (abs s) with - | (0, ps) -> - if ps >= ps_count_in_hour then pp_h_m ppf ~neg ps else - if ps >= ps_count_in_min then pp_m_s ppf ~neg ps else - if ps >= ps_count_in_s then pp_s ppf ~neg ps else - if ps >= ps_count_in_ms then pp_ms ppf ~neg ps else - if ps >= ps_count_in_us then pp_us ppf ~neg ps else - if ps >= ps_count_in_ns then pp_ns ppf ~neg ps else - pp_ps ppf ~neg ps - | (d, ps) -> - if d > 365 then pp_y_d ppf ~neg d ps else - pp_d_h ppf ~neg d ps -end - -(* POSIX timestamps *) - -let v (d, ps as s) = - if (ps < 0L || ps > ps_day_max || d < day_min || d > day_max) - then invalid_arg (Format.sprintf "illegal ptime timestamp: (%d,%Ld)" d ps) - else s - -let unsafe_of_d_ps s = s - -let of_span (d, _ as span) = - if d < day_min || d > day_max then None else Some span - -let to_span t = t - -let of_float_s secs = match Span.of_float_s secs with -| None -> None -| Some d -> of_span d - -let to_float_s = Span.to_float_s - -let truncate = Span.truncate_down - -let frac_s (_, ps) = (0, Int64.(rem ps ps_count_in_s)) - -(* Predicates *) - -let equal = Span.equal -let compare = Span.compare -let is_earlier t ~than = compare t than = -1 -let is_later t ~than = compare t than = 1 - -(* POSIX arithmetic *) - -let add_span t d = of_span (Span.add t d) -let sub_span t d = of_span (Span.sub t d) -let diff t1 t0 = Span.sub t1 t0 - -(* Time zone offsets between local and UTC timelines *) - -type tz_offset_s = int - -(* Date-time conversion - - POSIX time counts seconds since 1970-01-01 00:00:00 UTC without - counting leap seconds -- when a leap second occurs a POSIX second - can be two SI seconds or zero SI second. Hence 86400 POSIX seconds - always represent an UTC day and the translations below are accurate - without having to refer to a leap seconds table. *) - -type date = (int * int * int) -type time = (int * int * int) * tz_offset_s - -let max_month_day = (* max day number in a given year's month. *) - let is_leap_year y = (y mod 4 = 0) && (y mod 100 <> 0 || y mod 400 = 0) in - let mlen = [|31; 28 (* or not *); 31; 30; 31; 30; 31; 31; 30; 31; 30; 31|] in - fun y m -> if (m = 2 && is_leap_year y) then 29 else mlen.(m - 1) - -let is_date_valid (y, m, d) = - 0 <= y && y <= 9999 && - 1 <= m && m <= 12 && - 1 <= d && d <= max_month_day y m - -let is_time_valid ((hh, mm, ss), _) = - 0 <= hh && hh <= 23 && - 0 <= mm && mm <= 59 && - 0 <= ss && ss <= 60 - -let of_date_time (date, ((hh, mm, ss), tz_offset_s as t)) = - (* We first verify that the given date and time are Ptime-valid. - Once this has been established we find find the number of Julian - days since the epoch for the given proleptic Georgian calendar - date. This gives us the POSIX day component of the timestamp. The - remaining time fields are used to derive the picosecond precision - time in that day compensated by the time zone offset. The final - result is checked to be in Ptime's [min;max] range. - - By definition POSIX timestamps cannot represent leap seconds. - With the code below any date-time with a seconds value of 60 - (leap second addition) is mapped to the POSIX timestamp that - happens 1 second later which is what POSIX mktime would to. Any - formally non-existing UTC date-time with a seconds value of 59 - (leap second subtraction) is mapped on the POSIX timestamp that - represents this non existing instant. *) - if not (is_date_valid date && is_time_valid t) then None else - let d = jd_of_date date - jd_posix_epoch in - let hh_ps = Int64.(mul (of_int hh) ps_count_in_hour) in - let mm_ps = Int64.(mul (of_int mm) ps_count_in_min) in - let ss_ps = Int64.(mul (of_int ss) ps_count_in_s) in - let ps = Int64.(add hh_ps (add mm_ps ss_ps)) in - sub_span (d, ps) (Span.of_int_s tz_offset_s) - -let to_date_time ?(tz_offset_s = 0) t = - (* To render the timestamp in the given time zone offset we first - express the timestamp in local time and then compute the date - fields on that stamp as if it were UTC. If the local timestamp is - not in [min;max] then its date fields cannot be valid according - to the constraints guaranteed by Ptime and we fallback to UTC, - i.e. a time zone offset of 0. - - We then apply the following algorithm whose description makes - sense on a POSIX timestamp (i.e. UTC) but works equally well to - render the date-time fields of a local timestamp. - - We first take take the POSIX day count [d] (equivalent by - definition to an UTC day count) from the epoch, convert it to a - Julian day and use this to get the proleptic Gregorian calendar - date. The POSIX picoseconds [ps] in the day are are converted to - a daytime according to to its various units. - - By definition no POSIX timestamp can represent a date-time with a - seconds value of 60 (leap second addition) and thus the function - will never return a date-time with such a value. On the other - hand it will return an inexisting UTC date-time with a seconds - value of 59 whenever a leap second is subtracted since there is a - POSIX timestamp that represents this instant. *) - let (d, ps), tz_offset_s = match add_span t (Span.of_int_s tz_offset_s) with - | None -> t, 0 (* fallback to UTC *) - | Some local -> local, tz_offset_s - in - let jd = d + jd_posix_epoch in - let date = jd_to_date jd in - let hh = Int64.(to_int (div ps ps_count_in_hour)) in - let hh_rem = Int64.rem ps ps_count_in_hour in - let mm = Int64.(to_int (div hh_rem ps_count_in_min)) in - let mm_rem = Int64.rem hh_rem ps_count_in_min in - let ss = Int64.(to_int (div mm_rem ps_count_in_s)) in - date, ((hh, mm, ss), tz_offset_s) - -let of_date ?tz_offset_s:(tz = 0) date = of_date_time (date, ((00, 00, 00), tz)) -let to_date ?tz_offset_s t = fst (to_date_time ?tz_offset_s t) -let of_year ?tz_offset_s y = of_date ?tz_offset_s (y, 01, 01) -let to_year ?(tz_offset_s = 0) t = - let d = match add_span t (Span.of_int_s tz_offset_s) with - | None -> fst t (* fallback to UTC *) | Some (local_d, _) -> local_d - in - jd_to_year (d + jd_posix_epoch) - - -type weekday = [ `Sun | `Mon | `Tue | `Wed | `Thu | `Fri | `Sat ] - -let weekday_num ?(tz_offset_s = 0) t = - let (d, _) = Span.add t (Span.of_int_s tz_offset_s) in - (* N.B. in contrast to [to_date_time] we don't care if we fall outside - [min;max]. Even if it happens the result of the computation is still - correct *) - let i = (d + 4 (* Epoch, d = 0, was a thu, we want 4 for that day *)) mod 7 in - if i < 0 then 7 + i else i - -let weekday = - let wday = [| `Sun; `Mon; `Tue; `Wed; `Thu; `Fri; `Sat; |] in - fun ?tz_offset_s t -> wday.(weekday_num ?tz_offset_s t) - -(* RFC 3339 timestamp conversions *) - -(* RFC 3339 timestamp parser *) - -type error_range = int * int -type rfc3339_error = - [ `Invalid_stamp | `Eoi | `Exp_chars of char list | `Trailing_input ] - -let pp_rfc3339_error ppf = function -| `Invalid_stamp -> Format.fprintf ppf "@[invalid@ time@ stamp@]" -| `Eoi -> Format.fprintf ppf "@[unexpected@ end@ of@ input@]" -| `Trailing_input -> Format.fprintf ppf "@[trailing@ input@]" -| `Exp_chars cs -> - let rec pp_chars ppf = function - | c :: cs -> Format.fprintf ppf "@ %C" c; pp_chars ppf cs - | [] -> () - in - Format.fprintf ppf "@[expected@ a@ character@ in:%a@]" pp_chars cs - -let pp_range ppf (s, e) = - if s = e then Format.pp_print_int ppf s else Format.fprintf ppf "%d-%d" s e - -let _rfc3339_error_to_string (r, err) = - Format.asprintf "@[%a: %a@]" pp_range r pp_rfc3339_error err - -let rfc3339_string_error = function -| Ok _ as v -> v | Error (`RFC3339 e) -> Error (_rfc3339_error_to_string e) - -let rfc3339_error_to_msg = function -| Ok _ as v -> v | Error (`RFC3339 e) -> - Error (`Msg (_rfc3339_error_to_string e)) - -exception RFC3339 of (int * int) * rfc3339_error (* Internal *) - -let error r e = raise (RFC3339 (r, e)) -let error_pos p e = error (p, p) e -let error_exp_digit p = - error_pos p (`Exp_chars ['0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9']) - -let is_digit = function '0' .. '9' -> true | _ -> false - -let parse_digits ~count pos max s = - let stop = pos + count - 1 in - if stop > max then error_pos max `Eoi else - let rec loop k acc = - if k > stop then acc else - if is_digit s.[k] then loop (k+1) (acc * 10 + Char.code s.[k] - 0x30) else - error_exp_digit k - in - loop pos 0 - -let parse_char c pos max s = - if pos > max then error_pos max `Eoi else - if s.[pos] = c then () else error_pos pos (`Exp_chars [c]) - -let parse_dt_sep ~strict pos max s = - let is_dt_sep = function - | 'T' -> true - | 't' | ' ' when not strict -> true - | _ -> false - in - if pos > max then error_pos max `Eoi else - if is_dt_sep s.[pos] then () else - error_pos pos (`Exp_chars (['T'] @ if strict then [] else ['t'; ' '])) - -let decide_frac_or_tz ~strict pos max s = - if pos > max then error_pos max `Eoi else - match s.[pos] with - | '.' -> `Frac - | '+' | '-' | 'Z' -> `Tz - | 'z' when not strict -> `Tz - | c -> - let chars = ['.'; '+'; '-'; 'Z'] @ if strict then [] else ['z'] in - error_pos pos (`Exp_chars chars) - -let parse_frac_ps pos max s = - if pos > max then error_pos max `Eoi else - if not (is_digit s.[pos]) then error_exp_digit pos else - let rec loop k acc pow = - if k > max then error_pos max `Eoi else - if not (is_digit s.[k]) then (Some acc), k else - let count = k - pos + 1 in - if count > 12 then (* truncate *) loop (k + 1) acc pow else - let pow = Int64.div pow 10L in - let acc = Int64.(add acc (mul (of_int (Char.code s.[k] - 0x30)) pow)) in - loop (k + 1) acc pow - in - loop pos 0L ps_count_in_s - -let parse_tz_s ~strict pos max s = - let parse_tz_mag sign pos = - let hh_pos = pos in - let hh = parse_digits ~count:2 hh_pos max s in - let mm, mm_pos = match strict with - | true -> - let mm_pos = hh_pos + 3 in - parse_char ':' (mm_pos - 1) max s; - parse_digits ~count:2 mm_pos max s, mm_pos - | false -> - let next = hh_pos + 2 in - if next > max || not (s.[next] = ':' || is_digit s.[next]) - then (0, hh_pos (* end pos of parse - 1, one is added at the end *)) - else - let mm_pos = if s.[next] = ':' then hh_pos + 3 else hh_pos + 2 in - parse_digits ~count:2 mm_pos max s, mm_pos - in - if hh > 23 then error (hh_pos, hh_pos + 1) `Invalid_stamp else - if mm > 59 then error (mm_pos, mm_pos + 1) `Invalid_stamp else - let secs = hh * 3600 + mm * 60 in - let tz_s = match secs = 0 && sign = -1 with - | true -> None (* -00:00 convention *) - | false -> Some (sign * secs) - in - tz_s, mm_pos + 1 - in - if pos > max then error_pos max `Eoi else - match s.[pos] with - | 'Z' -> Some 0, pos - | 'z' when not strict -> Some 0, pos - | '+' -> parse_tz_mag ( 1) (pos + 1) - | '-' -> parse_tz_mag (-1) (pos + 1) - | c -> - let chars = ['+'; '-'; 'Z'] @ if strict then [] else ['z'] in - error_pos pos (`Exp_chars chars) - -let of_rfc3339 ?(strict = false) ?(sub = false) ?(start = 0) s = - try - let s_len = String.length s in - let max = s_len - 1 in - if s_len = 0 || start < 0 || start > max then error_pos start `Eoi else - let y_pos = start in - let m_pos = y_pos + 5 in - let d_pos = m_pos + 3 in - let hh_pos = d_pos + 3 in - let mm_pos = hh_pos + 3 in - let ss_pos = mm_pos + 3 in - let decide_pos = ss_pos + 2 in - let y = parse_digits ~count:4 y_pos max s in - parse_char '-' (m_pos - 1) max s; - let m = parse_digits ~count:2 m_pos max s in - parse_char '-' (d_pos - 1) max s; - let d = parse_digits ~count:2 d_pos max s in - parse_dt_sep ~strict (hh_pos - 1) max s; - let hh = parse_digits ~count:2 hh_pos max s in - parse_char ':' (mm_pos - 1) max s; - let mm = parse_digits ~count:2 mm_pos max s in - parse_char ':' (ss_pos - 1) max s; - let ss = parse_digits ~count:2 ss_pos max s in - let frac, tz_pos = match decide_frac_or_tz ~strict decide_pos max s with - | `Frac -> parse_frac_ps (decide_pos + 1) max s - | `Tz -> None, decide_pos - in - let tz_s_opt, last_pos = parse_tz_s ~strict tz_pos max s in - let tz_s = match tz_s_opt with None -> 0 | Some s -> s in - match of_date_time ((y, m, d), ((hh, mm, ss), tz_s)) with - | None -> error (start, last_pos) `Invalid_stamp - | Some t -> - let t, tz_s = match frac with - | None | Some 0L -> t, tz_s - | Some frac -> - match add_span t (0, frac) with - | None -> error (start, last_pos) `Invalid_stamp - | Some t -> t, tz_s - in - if not sub && last_pos <> max - then error_pos (last_pos + 1) `Trailing_input - else Ok (t, tz_s_opt, last_pos - start + 1) - with RFC3339 (r, e) -> Error (`RFC3339 (r, e)) - -(* RFC 3339 timestamp formatter *) - -let rfc3339_adjust_tz_offset tz_offset_s = - (* The RFC 3339 time zone offset field is limited in expression to - the bounds below with minute precision. If the requested time - zone offset exceeds these bounds or is not an *integral* number - of minutes we simply use UTC. An alternative would be to - compensate the offset *and* the timestamp but it's more - complicated to explain and maybe more surprising to the user. *) - let min = -86340 (* -23h59 in secs *) in - let max = +86340 (* +23h59 in secs *) in - if min <= tz_offset_s && tz_offset_s <= max && tz_offset_s mod 60 = 0 - then tz_offset_s, false - else 0 (* UTC *), true - -let s_frac_of_ps frac ps = - Int64.(div (rem ps ps_count_in_s) Span.frac_div.(frac)) - -let to_rfc3339 ?(space = false) ?frac_s:(frac = 0) ?tz_offset_s (_, ps as t) = - let buf = Buffer.create 255 in - let tz_offset_s, tz_unknown = match tz_offset_s with - | Some tz -> rfc3339_adjust_tz_offset tz - | None -> 0, true - in - let (y, m, d), ((hh, ss, mm), tz_offset_s) = to_date_time ~tz_offset_s t in - let dt_sep = if space then ' ' else 'T' in - Printf.bprintf buf "%04d-%02d-%02d%c%02d:%02d:%02d" y m d dt_sep hh ss mm; - let frac = if frac < 0 then 0 else (if frac > 12 then 12 else frac) in - if frac <> 0 then Printf.bprintf buf ".%0*Ld" frac (s_frac_of_ps frac ps); - if tz_offset_s = 0 && not tz_unknown then Printf.bprintf buf "Z" else - begin - let tz_sign = if tz_offset_s < 0 || tz_unknown then '-' else '+' in - let tz_min = abs (tz_offset_s / 60) in - let tz_hh = tz_min / 60 in - let tz_mm = tz_min mod 60 in - Printf.bprintf buf "%c%02d:%02d" tz_sign tz_hh tz_mm; - end; - Buffer.contents buf - -let pp_rfc3339 ?space ?frac_s ?tz_offset_s () ppf t = - Format.fprintf ppf "%s" (to_rfc3339 ?space ?frac_s ?tz_offset_s t) - -(* Pretty printing *) - -let pp_human ?frac_s:(frac = 0) ?tz_offset_s () ppf (_, ps as t) = - let tz_offset_s, tz_unknown = match tz_offset_s with - | Some tz -> rfc3339_adjust_tz_offset tz - | None -> 0, true - in - let (y, m, d), ((hh, ss, mm), tz_offset_s) = to_date_time ~tz_offset_s t in - Format.fprintf ppf "%04d-%02d-%02d %02d:%02d:%02d" y m d hh ss mm; - let frac = if frac < 0 then 0 else (if frac > 12 then 12 else frac) in - if frac <> 0 then Format.fprintf ppf ".%0*Ld" frac (s_frac_of_ps frac ps); - let tz_sign = if tz_offset_s < 0 || tz_unknown then '-' else '+' in - let tz_min = abs (tz_offset_s / 60) in - let tz_hh = tz_min / 60 in - let tz_mm = tz_min mod 60 in - Format.fprintf ppf " %c%02d:%02d" tz_sign tz_hh tz_mm; - () - -let pp = pp_human ~tz_offset_s:0 () -let dump = Span.dump - - -END OF FILE: ptime.ml -*) - -(* -FILE: ptime.mli --------------------- -(*--------------------------------------------------------------------------- - Copyright (c) 2015 The ptime programmers. All rights reserved. - SPDX-License-Identifier: ISC - ---------------------------------------------------------------------------*) - -(** POSIX time values. - - Consult the {{!basics}basics} and a few {{!notes}notes - and limitations}. - - {b References} - {ul - {- The Open Group. {{:http://pubs.opengroup.org/onlinepubs/9699919799/basedefs/V1_chap04.html#tag_04_15}The Open Group Base Specifications Issue 7, section 4.15 Seconds Since the Epoch}. 2013} - {- G. Klyne et al. - {{:http://tools.ietf.org/html/rfc3339} - {e Date and Time on the Internet: Timestamps}}. RFC 3339, 2002.}} *) - -(** {1:timespans POSIX time spans} *) - -type span -(** The type for signed picosecond precision POSIX time spans. A value - of this type represent the POSIX duration between two POSIX - timestamps. *) - -(** POSIX time spans. - - {b WARNING.} A POSIX time span is not equal to an SI second based time - span see the {{!basics}basics}. *) -module Span : sig - - (** {1:spans POSIX time spans} *) - - type t = span - (** The type for signed, picosecond precision, POSIX time spans. *) - - val v : int * int64 -> span - (** [v s] is like {!of_d_ps}[ s] but raises [Invalid_argument] if - [s] is not in the right range. Use {!of_d_ps} to deal with - untrusted input. *) - - val zero : span - (** [zero] is the neutral element of {!add}. *) - - val of_d_ps : int * int64 -> span option - (** [of_d_ps (d, ps)] is a span for the signed POSIX picosecond - span [d] * 86_400e12 + [ps]. [d] is a signed number of POSIX - days and [ps] a number of picoseconds in the range - \[[0];[86_399_999_999_999_999L]\]. [None] is returned if - [ps] is not in the right range. *) - - (**/**) - val unsafe_of_d_ps : int * int64 -> span - val unsafe_of_d_ps_option : (int * int64) option -> span option - (**/**) - - val to_d_ps : span -> int * int64 - (** [to_d_ps d] is the span [d] as a pair [(d, ps)] expressing the - POSIX picosecond span [d] * 86_400e12 + [ps] with - [ps] in the range \[[0];[86_399_999_999_999_999L]\] *) - - val of_int_s : int -> span - (** [of_int_s secs] is a span from the signed integer POSIX second - span [secs]. *) - - val to_int_s : span -> int option - (** [to_int_s d] is the span [d] as a signed integer POSIX second - span, if [int]'s range can represent it (note that this - depends on {!Sys.word_size}). Subsecond precision numbers are - truncated. *) - - val of_float_s : float -> span option - (** [of_float_s secs] is a span from the signed floating point POSIX - second span [d]. Subpicosecond precision numbers are truncated. - - [None] is returned if [secs] cannot be represented as a span. - This occurs on {!Stdlib.nan} or if the duration in POSIX - days cannot fit on an [int] (on 32-bit platforms this means the - absolute magnitude of the duration is greater than ~2'941'758 - years). *) - - val to_float_s : span -> float - (** [to_float_s s] is the span [d] as floating point POSIX seconds. - - {b Warning.} The magnitude of [s] may not be represented exactly - by the floating point value. *) - - (** {1:predicates Predicates} *) - - val equal : span -> span -> bool - (** [equal d d'] is [true] iff [d] and [d'] are the same time span. *) - - val compare : span -> span -> int - (** [compare d d'] is a total order on durations that is compatible - with signed time span order. *) - - (** {1:arith Arithmetic} - - {b Note.} The following functions rollover on overflows. *) - - val neg : span -> span - (** [neg d] is the span [d] negated. *) - - val add : span -> span -> span - (** [add d d'] is [d] + [d']. *) - - val sub : span -> span -> span - (** [sub d d'] is [d] - [d']. *) - - val abs : span -> span - (** [abs d] is the absolute value of span [d]. *) - - (** {1:rounding Rounding} *) - - val round : frac_s:int -> span -> span - (** [round ~frac_s t] is [t] rounded to the [frac_s] decimal - fractional second. Ties are rounded away from zero. [frac_s] is - clipped to the range \[[0];[12]\]. *) - - val truncate : frac_s:int -> span -> span - (** [truncate ~frac_s t] is [t] truncated to the [frac_s] decimal - fractional second. [frac_s] is clipped to the range - \[[0];[12]\]. *) - - (** {1:print Pretty printing} *) - - val pp : Format.formatter -> span -> unit - (** [pp ppf d] prints an unspecified, approximative, representation of [d] - on [ppf]. - - The representation is not fixed-width, depends on the magnitude of [d] - and uses locale independent - {{:http://www.bipm.org/en/publications/si-brochure/chapter3.html}SI - prefixes} on seconds and - {{:http://www.bipm.org/en/publications/si-brochure/table6.html}accepted - non-SI units}. Years are counted in Julian years (365.25 - SI-accepted days) as - {{:http://www.iau.org/publications/proceedings_rules/units/}defined} - by the International Astronomical Union (IUA). - - The representation is approximative. In particular beyond 60 - seconds it only keeps the two most significant time units and - rounds towards the infinity. The latter means that case arising, - it always {e over} approximates durations. - - {b Warning} Becomes unprecise (but does not overflow) if the - absolute number of POSIX days in the time span is greater than [max_int / - 4] (on 32-bit platforms this is ~735'439 years) *) - - val dump : Format.formatter -> span -> unit - (** [dump ppf s] prints an unspecified raw representation of [d] - on [ppf]. *) -end - -(** {1:timestamps POSIX timestamps} *) - -type t -(** The type for picosecond precision POSIX timestamps in the range - \[{!min};{!max}\]. Note that POSIX timestamps, and hence values of - this type, are by definition always on the UTC timeline. *) - -val v : int * int64 -> t -(** [v s] is [of_span (Span.v s)] but raise [Invalid_argument] if [s] - is not in the right range. Use {!Span.of_d_ps} and {!of_span} - to deal with untrusted input. *) - -val epoch : t -(** [epoch] is 1970-01-01 00:00:00 UTC. *) - -val min : t -(** [min] is 0000-01-01 00:00:00 UTC, the earliest timestamp - representable by {!Ptime}. *) - -val max : t -(** [max] is 9999-12-31 23:59:59.999999999999 UTC, the latest timestamp - representable by {!Ptime}. *) - -val of_span : span -> t option -(** [of_span d] is the POSIX time stamp that: - {ul - {- Happens at the POSIX span [d] {e after} {!epoch} - if [d] is positive.} - {- Happens at the POSIX span [d] {e before} {!epoch} - if [d] is negative.}} - [None] is returned if the timestamp is not in the range - \[{!min};{!max}\]. *) - -val to_span : t -> span -(** [to_span t] is the signed POSIX span that happen between [t] - and {!epoch}: - {ul - {- If the number is positive [t] happens {e after} {!epoch}.} - {- If the number is negative [t] happens {e before} {!epoch}.}} *) - -(**/**) -val unsafe_of_d_ps : int * int64 -> t -(**/**) - -val of_float_s : float -> t option -(** [of_float_s d] is like {!of_span} but with [d] as a floating point - second POSIX span [d]. This function is compatible with the result - of {!Unix.gettimeofday}. Decimal fractional seconds beyond [1e-12] - are truncated. *) - -val to_float_s : t -> float -(** [to_float_s t] is like {!to_span} but returns a floating point second - POSIX span. - - {b Warning.} Due to floating point inaccuracies do not expect the - function to round trip with {!of_float_s}; especially near - {!Ptime.min} and {!Ptime.max}. *) - -val truncate : frac_s:int -> t -> t -(** [truncate ~frac_s t] is [t] truncated to the [frac_s] decimal - fractional second. Effectively this reduces precision without - rounding, the timestamp remains in the second it is in. [frac_s] - is clipped to the range \[[0];[12]\]. *) - -val frac_s : t -> span -(** [frac_s t] is the (positive) fractional second duration in [t]. *) - -(** {1:predicates Predicates} *) - -val equal : t -> t -> bool -(** [equal t t'] is [true] iff [t] and [t'] are the same timestamps. *) - -val compare : t -> t -> int -(** [compare t t'] is a total order on timestamps that is compatible - with timeline order. *) - -val is_earlier : t -> than:t -> bool -(** [is_earlier t ~than] is [true] iff [compare t than = -1]. *) - -val is_later : t -> than:t -> bool -(** [is_later t than] is [true] iff [compare t than = 1]. *) - -(** {1:posix_arithmetic POSIX arithmetic} - - {b WARNING.} A POSIX time span is not equal to an SI second based - time span, see the {{!basics}basics}. Do not use these functions - to perform calendar arithmetic or measure wall-clock durations, - you will fail. *) - -val add_span : t -> span -> t option -(** [add_span t d] is timestamp [t + d], that is [t] with the signed - POSIX span [d] added. [None] is returned if the result is not - in the range \[{!min};{!max}\]. *) - -val sub_span : t -> span -> t option -(** [sub_span t d] is the timestamp [t - d], that is [t] with the - signed POSIX span [d] subtracted. [None] is returned if the result - is not in the range \[{!min};{!max}\]. *) - -val diff : t -> t -> span -(** [diff t t'] is the signed POSIX span [t - t'] that happens between - the timestamps [t] and [t']. *) - -(** {1:tz_offset Time zone offsets between local and UTC timelines} *) - -type tz_offset_s = int -(** The type for time zone offsets between local and UTC timelines - in seconds. This is the signed difference in seconds between the local - timeline and the UTC timeline: -{[ - tz_offset_s = local - UTC -]} - {ul - {- A value of [-3600] means that the local timeline is sixty minutes - {e behind} the UTC timeline.} - {- A value of [3600] means that the local timeline is sixty - minutes {e ahead} the UTC timeline.}} *) - -(** {1:date_time Date-time value conversions} - - A {e date-time} represents a point on the UTC timeline by pairing - a date in the proleptic Gregorian calendar and a second precision - daytime in a local timeline with stated relationship to the UTC - timeline. *) - -type date = int * int * int -(** The type for big-endian proleptic Gregorian dates. A triple - [(y, m, d)] with: - {ul - {- [y] the year from [0] to [9999]. [0] denotes -1 BCE - (this follows the - {{:http://www.iso.org/iso/home/standards/iso8601.htm}ISO 8601} - convention).} - {- [m] is the month from [1] to [12]} - {- [d] is the day from [1] to [28], [29], [30] or [31] - depending on [m] and [y]}} - - A date is said to be {e valid} iff the values [(y, m, d)] are - in the range mentioned above and represent an existing date in the - proleptic Gregorian calendar. *) - -type time = (int * int * int) * tz_offset_s -(** The type for daytimes on a local timeline. Pairs a triple [(hh, - mm, ss)] denoting the time on the local timeline and a [tz_offset] - stating the {{!tz_offset_s}relationship} of the local timeline to - the UTC timeline. - - The [(hh, mm, ss)] components are understood and constrainted as - follows: - {ul - {- [hh] is the hour from [0] to [23].} - {- [mm] is the minute from [0] to [59].} - {- [ss] is the seconds from [0] to [60]. [60] may happen whenever - a leap second is added.}} - A [time] value is said to be {e valid} iff the values [(hh, mm, ss)] - are in the ranges mentioned above. *) - -(** {2:datetimes Date and time} *) - -val of_date_time : date * time -> t option -(** [of_date_time dt] is the POSIX timestamp corresponding to - date-time [dt] or [None] if [dt] has an {{!date}invalid date}, - {{!time}invalid time} or the date-time is not in the range - \[{!min};{!max}\]. - - {b Leap seconds.} Any date-time with a seconds value of [60], hence - representing a leap second addition, is mapped to the date-time - that happens 1 second later. Any date-time with a seconds value of - [59] is mapped to the POSIX timestamp that represents this - instant, if a leap second was subtracted at that point, this is - the POSIX timestamp that represents this inexisting instant. See - the {{!basics}basics}. *) - -val to_date_time : ?tz_offset_s:tz_offset_s -> t -> date * time -(** [to_date_time ~tz_offset_s t] is the date-time of the timestamp [t]. - - [tz_offset_s] hints the time zone offset used for the resulting - daytime component (defaults to [0], i.e. UTC). The offset is not - honoured and fallbacks to [0] in case the resulting date-time - rendering of the timestamp would yield an {{!date}invalid - date}. This means that you should always interpret the resulting - time component with the time zone offset it is paired with in the - result and not assume it will be the one you gave to the - function. Note that for real-world time zone offsets the fallback - to [0] will only happen around {!Ptime.min} and {!Ptime.max}. - Formally the fallback occurs whenever [add_span t (Span.of_int_s - tz_offset_s)] is [None]. - - {b Leap seconds.} No POSIX timestamp can represent a date-time - with a leap second added, hence this function will never return a - date-time with a [60] seconds value. This function does return - inexisting UTC date-times with [59] seconds whenever a leap second is - subtracted since POSIX timestamps do represent them. See the - {{!basics}basics}. - - {b Subsecond precision.} POSIX timestamps with subsecond precision - are floored, i.e. the date-time always has the second mentioned in - the timestamp. *) - -(** {2:dates Date} *) - -val of_date : ?tz_offset_s:tz_offset_s -> date -> t option -(** [of_date d] is - [of_date_time (d, ((00, 00, 00), tz_offset_s))]. [tz_offset_s] - defaults to 0, i.e. UTC. *) - -val to_date : ?tz_offset_s:tz_offset_s -> t -> date -(** [to_date t] is [fst (to_date_time ?tz_offset_s t)]. *) - -(** {2:years Year} *) - -val of_year : ?tz_offset_s:tz_offset_s -> int -> t option -(** [of_year y] is [of_date ?tz_offset_s (y, 01, 01)]. *) - -val to_year : ?tz_offset_s:tz_offset_s -> t -> int -(** [to_year t] is the first component of [(to_date ?tz_offset_s t))] but - more efficient. *) - -(** {2:weekdays Week days} *) - -type weekday = [ `Sun | `Mon | `Tue | `Wed | `Thu | `Fri | `Sat ] -(** The type for the days of the 7-day week. *) - -val weekday : ?tz_offset_s:tz_offset_s -> t -> weekday -(** [weekday ~tz_offset_s t] is the day in the 7-day week of timestamp [t] - expressed in the time zone offset [ts_offset_s] (defaults to [0]). *) - -val weekday_num : ?tz_offset_s:tz_offset_s -> t -> int -(** [weekday_num] is like {!weekday} but returns a weekday number, 0 - is sunday, 1 is monday, …, 6 is saturday etc. *) - -(** {1:rfc3339 RFC 3339 timestamp conversions} *) - -type error_range = int * int -(** The type for error ranges, starting and ending position. *) - -type rfc3339_error = - [ `Invalid_stamp - | `Eoi - | `Exp_chars of char list - | `Trailing_input ] -(** The type for RFC 3339 timestamp parsing errors. [`Invalid_stamp] - means that either the time stamp is not in the range - \[{!min};{!max}\], or the date is invalid, or one of the fields is - not in the right range. *) - -val pp_rfc3339_error : Format.formatter -> rfc3339_error -> unit -(** [pp_rfc3339_error ppf e] prints an unspecified representation of - [e] on [ppf]. *) - -val rfc3339_error_to_msg : ('a, [`RFC3339 of error_range * rfc3339_error]) - result -> ('a, [> `Msg of string]) result -(** [rfc3339_error_to_msg r] converts RFC 3339 parse errors to error - messages. *) - -val rfc3339_string_error : - ('a, [`RFC3339 of error_range * rfc3339_error]) result -> ('a, string) result -(** [rfc3339_string_error r] converts RFC 3339 parse errors errors to - string errors. *) - -val of_rfc3339 : ?strict:bool -> ?sub:bool -> ?start:int -> string -> - ((t * tz_offset_s option * int), - [> `RFC3339 of error_range * rfc3339_error]) result -(** [of_rfc3339 ~strict ~sub ~start s] parses an RFC 3339 - {{:https://tools.ietf.org/html/rfc3339#section-5.6}[date-time]} - starting at [start] (defaults to [0]) in [s] to a triple [(t, tz, count)] - with: - {ul - {- [t] the POSIX timestamp (hence on the UTC timeline).} - {- [tz], the optional {{!tz_offset_s}time zone offset} found in the - timestamp. [None] is returned iff the date-time satisfies the - {{:https://tools.ietf.org/html/rfc3339#section-4.3}unknown local - offset convention}.} - {- [count] the number of bytes read starting at [start] to parse the - timestamp. If [sub] is [false] (default) this is always - [String.length s - start] and [Error `Trailing_input] is returned - if there are still bytes in [s] after the date-time was parsed. Use - [~sub:true] for allowing trailing input to exist.} - {- [strict] if [false] (default) the pasring function does - not error on timestamp with lowercase ['T'] or ['Z'] characters, or - space separated date and times, and `hhmm` and `hh` timezone - offsets (strict mandates [hh:mm]). This allows to parse a slightly - larger subset of ISO 8601 than what RFC 3339 allows}} - - {b Notes and limitations.} - {ul - {- If [start] is not an index of [s], [Error ((start, start), `Eoi)] is - returned.} - {- RFC 3339 allows a few degenerate (I say) timestamps with - non-zero time zone offsets to be parsed at the boundaries that - correspond to timestamps that cannot be expressed in UTC in RFC - 3339 itself (e.g. [0000-01-01T00:00:00+00:01]). The function - errors on these timestamps with [`Invalid_stamp] as they cannot - be represented in the range \[{!min};{!max}\].} - {- Leap seconds are allowed on any date-time and handled as in - {!of_date_time}} - {- Fractional parts beyond the picosecond ([1e-12]) are truncated.}} *) - -val to_rfc3339 : ?space:bool -> ?frac_s:int -> ?tz_offset_s:tz_offset_s -> - t -> string -(** [to_rfc3339_tz ~space ~frac_s ~tz_offset_s t] formats the timestamp - [t] according to a RFC 3339 - {{:https://tools.ietf.org/html/rfc3339#section-5.6}[date-time]} - production with: - {ul - {- [tz_offset_s] hints the time zone offset to use, use [0] for UTC. - The hint is ignored in the following cases: if [tz_offset_s] is not an - integral number of minutes and its magnitude not in the range permitted - by the standard, if [add_span t (Span.of_int_s tz_offset_s)] is [None] - (the resulting timestamp rendering would not be RFC 3339 compliant). - If either the hint is ignored or [tz_offset_s] is unspecified then - the - {{:https://tools.ietf.org/html/rfc3339#section-4.3}unknown local offset - convention} is used to render the time zone component.} - {- [frac_s], clipped to the range \[[0];[12]\] specifies that exactly - [frac_s] decimal digits of the fractional second of [t] are - rendered (defaults to [0]).} - {- [space] if [true] the date and time separator is a space - rather than a ['T'] (not recommended but may be allowed by the - protocol you are dealing with, defaults to [false]).}} *) - -val pp_rfc3339 : ?space:bool -> ?frac_s:int -> ?tz_offset_s:tz_offset_s -> - unit -> Format.formatter -> t -> unit -(** [pp_rfc3339 ?space ?frac_s ?tz_offset_s () ppf t] is - [Format.fprintf ppf "%s" (to_rfc3339 ?space ?frac_s ?tz_offset_s t)]. *) - -(** {1:print Pretty printing} *) - -val pp_human : ?frac_s:int -> ?tz_offset_s:tz_offset_s -> unit -> - Format.formatter -> t -> unit -(** [pp_human ~frac_s ~tz_offset_s () ppf t] prints an unspecified, human - readable, locale-independent, representation of [t] with: - {ul - {- [tz_offset_s] hints the time zone offset to use. The hint is ignored - in the following cases: if [tz_offset_s] is not an integral number of - minutes and its magnitude not in the range permitted by the standard, - if [add_span t (Span.of_int_s tz_offset_s)] is [None]. - If either the hint is ignored or [tz_offset_s] is unspecified then - RFC 3339's - {{:https://tools.ietf.org/html/rfc3339#section-4.3}unknown local offset - convention} is used to render the time zone component.} - {- [frac_s] clipped to the range \[[0];[12]\] specifies that exactly - [frac_s] decimal digits of the fractional second of [t] are - rendered (defaults to [0]).}} - - {b Note.} The output of this function is similar to but {b not} - compliant with RFC 3339, it should only be used for presentation, - not as a serialization format. *) - -val pp : Format.formatter -> t -> unit -(** [pp] is [pp_human ~tz_offset_s:0]. *) - -val dump : Format.formatter -> t -> unit -(** [dump ppf t] prints an unspecified raw representation of [t] - on [ppf]. *) - -(** {1:basics Basics} - - POSIX time counts POSIX seconds since the epoch 1970-01-01 - 00:00:00 UTC. As such a POSIX timestamp is {b always} on the UTC - timeline. - - POSIX time doesn't count leap seconds, so by definition it cannot - represent them. One way of viewing this is that whenever a leap - second is added a POSIX second lasts two SI seconds and whenever a - leap second is subtracted a POSIX second lasts zero SI second. - - {!Ptime} does not provide any mean to convert the duration between - two POSIX timestamps to SI seconds. The reason is that in order to - accurately find this number, a - {{:http://www.ietf.org/timezones/data/leap-seconds.list}leap - second table} is needed. However since this table may change every - six months, {!Ptime} decides not to include it so as not to - potentially become incorrect every six months. - - This decision has the following implications. First it should be - realised that the durations mentioned by the {!add_span}, - {!sub_span} and {!diff} functions are expressed in {e - POSIX seconds} which may represent zero, one, or two SI - seconds. For example if we add 1 second with - {!add_span} to the POSIX timestamp for 1998-12-31 23:59:59 UTC, - what we get is the timestamp for 1999-01-01 00:00:00 UTC: -{[ -let get = function None -> assert false | Some v -> v -let utc d t = get @@ Ptime.of_date_time (d, (t, 0)) -let t0 = utc (1998, 12, 31) (23, 59, 59) -let t1 = utc (1999, 01, 01) (00, 00, 00) -let one_s = Ptime.Span.of_int_s 1 -let () = assert (Ptime.equal (get @@ Ptime.add_span t0 one_s) t1) -]} - However since the leap second 1998-12-31 23:59:60 UTC exists, - {e two} actual SI seconds elapsed between [t0] and [t1]. Now if we use - {!diff} to find the POSIX duration that elapsed between - [t0] and [t1] we get one POSIX second: -{[ -let () = assert (Ptime.Span.equal (Ptime.diff t1 t0) one_s) -]} - But still, two SI seconds elapsed between these two points in - time. Note also that no value of type {!t} can represent the UTC - timetamp 1998-12-31 23:59:60 and hence {!Ptime.to_date_time} - will never return a date-time with a seconds value of [60]. In - fact both 1998-12-31 23:59:60 UTC and 1999-01-01 00:00:00 UTC are - represented by the same timestamp: -{[ -let t2 = utc (1998, 12, 31) (23, 59, 60) -let () = assert (Ptime.equal t1 t2) -]} - This is true of any added leap second, we map it on the first second - of the next minute, thus matching the behaviour - of POSIX's - {{:http://pubs.opengroup.org/onlinepubs/9699919799/functions/mktime.html} - mktime} function. - - If a leap second is subtracted on a day the following occurs – - 2015, as of writing this never happened. Let YYYY-06-30 23:59:58 - be the instant a leap second is subtracted, this means that the - next UTC date-time, one SI second later, is YYYY-07-01 - 00:00:00. However if we diff the two instants: -{[ -let y = 9999 (* hypothetical year were this happens *) -let t0 = utc (y, 06, 30) (23, 59, 58) -let t1 = utc (y, 07, 01) (00, 00, 00) -let two_s = Ptime.Span.of_int_s 2 -let () = assert (Ptime.Span.equal (Ptime.diff t1 t0) two_s) -]} - We get two POSIX seconds, but only one SI second - elapsed between these two points in time. It should also - be noted that POSIX time will represent a point that never - existed in time namely YYYY-06-30 23:59:59, the POSIX second - with 0 SI second duration and that {!Ptime.to_date_time} - will return a date-time value for this timestamp even though - it never existed: -{[ -let t2 = utc (y, 06, 30) (23, 59, 59) -let () = assert (Ptime.equal (get @@ Ptime.add_span t0 one_s) t2) -]} - - {1:notes Notes and limitations} - - The following points should be taken into account - {ul - {- {!Ptime} is not a calendar library and will never be.} - {- {!Ptime} can only represent picosecond precision timestamps in - the range \[{!Ptime.min};{!Ptime.max}\]. It is however able to - convert {e any} of these timestamps to a valid date-time or RFC - 3339 timestamp.} - {- POSIX time in general is ill-suited to measure wall-clock - time spans for the following reasons. - {ul - {- POSIX time counts time in POSIX seconds. POSIX - seconds can represent 2, 1 or 0 SI seconds. [Ptime] - offers no mechanism to determine the SI duration between - two timestamps, see the {{!basics}basics}.} - {- The POSIX timestamps returned by your platform are not - monotonic: they are subject to operating system time - adjustements and can even go back in time. If you need to - measure time spans in a single program run use a monotonic - time source (e.g. {!Mtime}).}}}} -*) - -END OF FILE: ptime.mli -*) - (* CASE ANALYSIS PREDICATES + - id: P00 + pattern: Ha un SUMMARY? + ics: "SUMMARY:…" + remind_support: nativo + strategia: "REM MSG " + snippet: 'REM 2025-12-25 MSG Natale' + priorita: Subito + - id: P01 pattern: All-day singolo ics: "DTSTART;VALUE=DATE, opzionale DTEND=giorno+1" @@ -2188,49 +172,88 @@ END OF FILE: ptime.mli *) type event_description = - [ `All_day_event_single (* P01 *) + [ `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 *) ] + | `Exception_events (* P10 *) + | `Override_events (* P11 *) ] [@@deriving show] -type predicate = Icalendar.event -> bool +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] -let all_day_event_single ev : bool = +type predicate = Icalendar.event -> features list option + +let has_summary ev : features list option = + (* P00 *) + let summary_opt = + List.find_map + (function + | `Summary (_, s) -> Some [Summary s] + | _ -> None) + ev.props + in + match summary_opt with + | Some s -> Some s + | None -> None + +let all_day_event_single ev : features list option = (* P01 *) let _, dtstart = ev.dtstart in match dtstart with - | `Date d -> begin - match ev.dtend_or_duration with - | None -> true + | `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 true else false + 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 - | _ -> false - end - | _ -> begin false end + | _ -> None -let all_day_event_multi ev : bool = +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 -> false + | `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 true else false + 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 - | _ -> false - end - | _ -> begin false end + | _ -> None -let timed_event ev : bool = +let timed_event ev : features list option = (* P03 and P04 *) let _, dtstart = ev.dtstart in let start_td = get_start ev in @@ -2239,63 +262,96 @@ let timed_event ev : bool = | `Datetime (`Local _) -> begin Printf.printf "Local time event: %s\n" uid; Printf.printf " Timedesc: %s\n" (start_td |> Timedesc.to_rfc3339); - true - end + 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); - true - end + 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); - true - end + 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); - false - end + None + end -let weekly_simple_recurrence ev : bool = +let weekly_simple_recurrence ev : features list option = (* P05 *) let rrules = ev.rrule in match rrules with - | None -> false + | None -> None | Some (_, (`Weekly, _, _, _)) -> begin Printf.printf " Weekly simple recurrence event\n"; - true - end - | _ -> false + Some [Generic_feature_presence] + end + | _ -> None -let daily_simple_recurrence ev : bool = +let daily_simple_recurrence ev : features list option = (* P06 *) let rrules = ev.rrule in match rrules with - | None -> false + | None -> None | Some (_, (`Daily, _, _, _)) -> begin Printf.printf " Daily simple recurrence event\n"; - true - end - | _ -> false + Some [Generic_feature_presence] + end + | _ -> None -let exception_events ev : bool = +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); - true + Some [Generic_feature_presence] end - else false + 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 + 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 let all_predicates : (predicate * 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); ] diff --git a/bin/eventTransformer.ml b/bin/eventTransformer.ml index 3edecfe..8930584 100644 --- a/bin/eventTransformer.ml +++ b/bin/eventTransformer.ml @@ -3,13 +3,19 @@ let default_implementation = Remind.make_default_event "TODO: implement conversi let remind_of_event (ev : Icalendar.event) : Remind.event = let found = ListLabels.fold_left ~init:[] EventPredicates.all_predicates ~f:(fun acc (pred, desc) -> - if pred ev then desc :: acc else acc) + match pred ev with + | Some feats -> (desc, feats) :: acc + | None -> acc) |> List.rev in if List.length found > 0 then begin - Printf.printf " 󰧓 ⇒ matches these predicates:\n"; - List.iter (fun d -> Printf.printf " - %s\n" (EventPredicates.show_event_description d)) found; + 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 40994a2..42d304d 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -1,3 +1,12 @@ +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 + (e.g., due to updates or recurring events or cancellations). +*) + let ical2rem ical_file = let ic = open_in ical_file in let n = in_channel_length ic in @@ -8,18 +17,30 @@ let ical2rem ical_file = match cal_or_error with | Error e -> prerr_endline ("Error parsing iCalendar file: " ^ e) | Ok (_, components) -> begin - let events = ref 0 in - List.iter - (fun comp -> - match comp with - | `Event event -> - events := !events + 1; - let uid = Utils.get_uid event in - Printf.printf "󰧓 ⇒ UID: %s\n" uid; - Printf.printf "%s\n\n\n" (Icalendar.show_component comp) - | _ -> () (* Ignore non-event components *)) - components; - Printf.printf "\nEvents: %d\n" !events; + 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 + + (* 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 @@ -27,8 +48,10 @@ let ical2rem ical_file = | _ -> None) components in + let _reminders = List.map EventTransformer.remind_of_event events in + () - end + end let () = if !Sys.interactive then () else exit (CommandLine.main ical2rem) diff --git a/bin/remind.ml b/bin/remind.ml index a624c29..cb85036 100644 --- a/bin/remind.ml +++ b/bin/remind.ml @@ -1,3 +1,7 @@ +(* + FILE INTERAMENTE GENERATO DA LLM, DA RIVEDERE COMPLETAMENTE +*) + (** Types for representing Remind events *) (** Weekday names in Remind format *) diff --git a/bin/utils.ml b/bin/utils.ml index 85bda98..d4f0779 100644 --- a/bin/utils.ml +++ b/bin/utils.ml @@ -24,6 +24,10 @@ 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