pdonadeo/ical2rem
1
0
Fork 0
Code Issues Pull Requests Actions Projects Releases 1 Activity
Files
83dfd0dfa971e6939ae8223004c94ce3a33d8fac
ical2rem/bin/eventPredicates.ml
Paolo Donadeo 83dfd0dfa9 feat: initial implementation of iCalendar to Remind converter 
- Add project scaffolding (dune, dune-project, opam, .ocamlformat)
- Implement basic parsing and handling of iCalendar events
- Add event predicates for common event types (all-day, timed,
  recurrence, exceptions)
- Add transformation logic to map iCalendar events to Remind format
  (stub implementation)
- Provide utilities for extracting event details and converting
  dates/times
- Set up executable entrypoint and command-line interface using Cmdliner
- Include Remind event type definitions and helpers
2025-11-30 19:33:35 +01:00

2302 lines
82 KiB
OCaml
Raw Blame History

This file contains ambiguous Unicode characters
This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
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 "@[<h>%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: P01
pattern: All-day singolo
ics: "DTSTART;VALUE=DATE, opzionale DTEND=giorno+1"
remind_support: nativo
strategia: "REM <data> MSG <summary>"
snippet: 'REM 2025-12-25 MSG Natale'
priorita: Subito
- id: P02
pattern: All-day multi-giorno
ics: "DTSTART;VALUE=DATE + DTEND;VALUE=DATE esclusivo"
remind_support: nativo+accorgimenti
strategia: "espandi in eventi giornalieri; stesso SUMMARY"
snippet: 'REM 2025-08-10 THROUGH 2025-08-15 MSG Ferie # oppure espansione per-giorno'
priorita: Subito
- id: P03
pattern: Evento a orario locale
ics: "DTSTART;TZID=… + DTEND oppure DURATION"
remind_support: nativo
strategia: "REM <data> AT <hh:mm> [DURATION] MSG …"
snippet: 'REM 2025-10-05 AT 09:00 DURATION 1:00 MSG Riunione'
priorita: Subito
- id: P04
pattern: Evento a orario in UTC
ics: "DTSTART/DTEND con suffisso Z"
remind_support: nativo+accorgimenti
strategia: "converti a fuso locale prima di emettere AT"
snippet: 'REM 2025-09-03 AT 06:45 MSG Treno'
priorita: Subito
- id: P05
pattern: Ricorrenza settimanale semplice
ics: "RRULE:FREQ=WEEKLY;BYDAY=…;[UNTIL|COUNT]"
remind_support: nativo
strategia: "REM <giorni> FROM <start> [UNTIL <end>] AT <hh:mm> MSG …"
snippet: 'REM Mon Wed FROM 2025-09-01 UNTIL 2025-10-31 AT 09:00 MSG Standup'
priorita: Subito
- id: P06
pattern: Ricorrenza giornaliera semplice
ics: "RRULE:FREQ=DAILY;[UNTIL|COUNT]"
remind_support: nativo
strategia: "REM FROM <start> UNTIL <end> AT <hh:mm> EVERY 1 MSG …"
snippet: 'REM FROM 2025-10-01 UNTIL 2025-10-10 AT 08:30 MSG Daily'
priorita: Subito
- id: P07
pattern: Ricorrenza mensile per giorno fisso
ics: "RRULE:FREQ=MONTHLY;BYMONTHDAY=…"
remind_support: nativo
strategia: "REM <giorno-num> AT <hh:mm> FROM/UNTIL"
snippet: 'REM 15 AT 10:00 FROM 2025-01-01 MSG Fatture'
priorita: Dopo
- id: P08
pattern: Ricorrenza “n-esimo weekday” del mese
ics: "RRULE:FREQ=MONTHLY;BYDAY=MO;BYSETPOS=3"
remind_support: espansione
strategia: "materializza occorrenze in singoli REM o calcola in codice"
snippet: '# genera REM per ciascuna data calcolata'
priorita: Dopo
- id: P09
pattern: Ricorrenza annuale semplice
ics: "RRULE:FREQ=YEARLY;[BYMONTH][BYMONTHDAY]"
remind_support: nativo
strategia: "REM <data ricorrente> MSG …"
snippet: 'REM Jul 29 MSG Compleanno'
priorita: Dopo
- id: P10
pattern: Eccezioni
ics: "EXDATE (una o più), RDATE aggiuntive"
remind_support: nativo+accorgimenti
strategia: "usa OMIT per rimuovere date; aggiungi REM singoli per RDATE"
snippet: 'REM Mon AT 09:00 FROM 2025-09-01 UNTIL 2025-10-31 MSG Standup\nOMIT 2025-10-13'
priorita: Subito
- id: P11
pattern: Override/cancellazioni per istanza
ics: "RECURRENCE-ID con contenuto modificato o STATUS:CANCELLED"
remind_support: espansione
strategia: "OMIT la data dalla serie; aggiungi REM singolo con i campi override"
snippet: '# serie + REM specifico per l’istanza'
priorita: Subito
- id: P12
pattern: DURATION al posto di DTEND
ics: "DURATION:PT…"
remind_support: nativo
strategia: "mappa su DURATION <h:mm> in REM"
snippet: 'REM 2025-10-05 AT 14:00 DURATION 2:30 MSG Workshop'
priorita: Subito
- id: P13
pattern: Allarmi
ics: "VALARM DISPLAY/AUDIO/EMAIL; TRIGGER relativo"
remind_support: parziale
strategia: "mappa 1 allarme principale su WARN; multipli opzionali come REM duplicati HIDE"
snippet: 'REM 2025-10-05 AT 09:00 WARN 15 MSG Riunione'
priorita: Dopo
- id: P14
pattern: Fusi orari dichiarati (VTIMEZONE, TZID diversi)
ics: "VTIMEZONE + DTSTART;TZID=…"
remind_support: nativo+accorgimenti
strategia: "normalizza tutto al fuso locale del sistema prima dell’output"
snippet: '# conversione in pre-processing'
priorita: Subito
- id: P15
pattern: Partecipanti/organizzatore
ics: "ORGANIZER, ATTENDEE*, PARTSTAT…"
remind_support: non previsto
strategia: "appendi a DESCRIPTION/MSG come testo"
snippet: '# nessuna semantica in Remind'
priorita: Quando serve
- id: P16
pattern: Allegati/URL esterni
ics: "ATTACH, URL"
remind_support: non previsto
strategia: "conserva URL in coda al MSG"
snippet: '# link nel testo'
priorita: Quando serve
- id: P17
pattern: Meeting online (Google/Teams metadati)
ics: "X-GOOGLE-CONFERENCE, X-MICROSOFT-*"
remind_support: non previsto
strategia: "estrai solo URL di join nel MSG"
snippet: '# riduci al link'
priorita: Quando serve
- id: P18
pattern: Visibilità/trasparenza
ics: "CLASS, TRANSP"
remind_support: non previsto
strategia: "ignora o aggiungi prefisso [FREE]/[BUSY] nel MSG"
snippet: '# opzionale'
priorita: Ignora
- id: P19
pattern: Stato/versioning
ics: "STATUS, SEQUENCE, CREATED, LAST-MODIFIED"
remind_support: non previsto
strategia: "ignora; usa solo STATUS:CANCELLED per soppressioni"
snippet: '# già coperto in P11'
priorita: Ignora
- id: P20
pattern: Categorie/etichette
ics: "CATEGORIES:…"
remind_support: parziale
strategia: "prefisso nel MSG o uso TAG se ti serve filtrare"
snippet: 'REM 2025-10-05 AT 09:00 TAG Work MSG [Work] Riunione'
priorita: Dopo
*)
type event_description =
[ `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 *) ]
[@@deriving show]
type predicate = Icalendar.event -> bool
let all_day_event_single ev : bool =
(* P01 *)
let _, dtstart = ev.dtstart in
match dtstart with
| `Date d -> begin
match ev.dtend_or_duration with
| None -> true
| 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
end
| _ -> false
end
| _ -> begin false end
let all_day_event_multi ev : bool =
(* P02 *)
let _, dtstart = ev.dtstart in
match dtstart with
| `Date d -> begin
match ev.dtend_or_duration with
| None -> false
| 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
end
| _ -> false
end
| _ -> begin false end
let timed_event ev : bool =
(* 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);
true
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
| `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
| `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
let weekly_simple_recurrence ev : bool =
(* P05 *)
let rrules = ev.rrule in
match rrules with
| None -> false
| Some (_, (`Weekly, _, _, _)) -> begin
Printf.printf " Weekly simple recurrence event\n";
true
end
| _ -> false
let daily_simple_recurrence ev : bool =
(* P06 *)
let rrules = ev.rrule in
match rrules with
| None -> false
| Some (_, (`Daily, _, _, _)) -> begin
Printf.printf " Daily simple recurrence event\n";
true
end
| _ -> false
let exception_events ev : bool =
(* 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
end
else false
let all_predicates : (predicate * event_description) list =
[
(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);
]
Reference in New Issue View Git Blame Copy Permalink