diff --git a/src/utils/time.ml b/src/utils/time.ml index e52fa775a..c4ea6f4dc 100644 --- a/src/utils/time.ml +++ b/src/utils/time.ml @@ -10,106 +10,125 @@ open Error_monad open CalendarLib -type t = int64 +module T = struct + include Int64 -let compare = Int64.compare -let (=) x y = compare x y = 0 -let equal = (=) -let (<>) x y = compare x y <> 0 -let (<) x y = compare x y < 0 -let (<=) x y = compare x y <= 0 -let (>=) x y = compare x y >= 0 -let (>) x y = compare x y > 0 -let min x y = if x <= y then x else y -let max x y = if x <= y then y else x + let diff a b = + let sign = a >= b in + let res = Int64.sub a b in + let res_sign = res >= 0L in + if sign = res_sign then res else invalid_arg "Time.diff" ;; -let add = Int64.add -let diff = Int64.sub + let add a d = + let sign = d >= 0L in + let res = Int64.add a d in + let incr_sign = res >= a in + if sign = incr_sign then res else invalid_arg "Time.add" ;; -let now () = Int64.of_float (Unix.gettimeofday ()) + let hash = to_int + let (=) = equal + let (<>) x y = compare x y <> 0 + let (<) x y = compare x y < 0 + let (<=) x y = compare x y <= 0 + let (>=) x y = compare x y >= 0 + let (>) x y = compare x y > 0 + let min x y = if x <= y then x else y + let max x y = if x <= y then y else x -let of_seconds x = x -let to_seconds x = x + let min_value = min_int + let epoch = 0L + let max_value = max_int -let formats = - [ "%Y-%m-%dT%H:%M:%SZ" ; "%Y-%m-%d %H:%M:%SZ"; - "%Y-%m-%dT%H:%M:%S%:z"; "%Y-%m-%d %H:%M:%S%:z"; ] + let now () = Int64.of_float (Unix.gettimeofday ()) -let int64_of_calendar c = - let round fc = - let f, i = modf fc in - Int64.(add (of_float i) Pervasives.(if f < 0.5 then 0L else 1L)) in - round @@ Calendar.Precise.to_unixfloat c + let of_seconds x = x + let to_seconds x = x -let rec iter_formats s = function - | [] -> None - | f :: fs -> - try - Some (int64_of_calendar @@ Printer.Precise_Calendar.from_fstring f s) - with _ -> iter_formats s fs + let formats = + [ "%Y-%m-%dT%H:%M:%SZ" ; "%Y-%m-%d %H:%M:%SZ"; + "%Y-%m-%dT%H:%M:%S%:z"; "%Y-%m-%d %H:%M:%S%:z"; ] -let of_notation s = - iter_formats s formats -let of_notation_exn s = - match of_notation s with - | None -> invalid_arg "Time.of_notation: can't parse." - | Some t -> t + let int64_of_calendar c = + let round fc = + let f, i = modf fc in + Int64.(add (of_float i) Pervasives.(if f < 0.5 then 0L else 1L)) in + round @@ Calendar.Precise.to_unixfloat c -let to_notation t = - let ft = Int64.to_float t in - if Int64.of_float ft <> t then - "out_of_range" - else - Printer.Precise_Calendar.sprint - "%Y-%m-%dT%H:%M:%SZ" - (Calendar.Precise.from_unixfloat ft) + let rec iter_formats s = function + | [] -> None + | f :: fs -> + try + Some (int64_of_calendar @@ Printer.Precise_Calendar.from_fstring f s) + with _ -> iter_formats s fs -let rfc_encoding = - let open Data_encoding in - def - "timestamp" @@ - describe - ~title: - "RFC 339 formatted timestamp" - ~description: - "A date in human readble form as specified in RFC 3339." @@ - conv - to_notation - (fun s -> match of_notation s with - | Some s -> s - | None -> Data_encoding.Json.cannot_destruct "Time.of_notation") - string + let of_notation s = + iter_formats s formats + let of_notation_exn s = + match of_notation s with + | None -> invalid_arg "Time.of_notation: can't parse." + | Some t -> t -let encoding = - let open Data_encoding in - splitted - ~binary: int64 - ~json: - (union [ - case - rfc_encoding - (fun i -> Some i) - (fun i -> i) ; - case - int64 - (fun _ -> None) - (fun i -> i) ; - ]) + let to_notation t = + let ft = Int64.to_float t in + if Int64.of_float ft <> t then + "out_of_range" + else + Printer.Precise_Calendar.sprint + "%Y-%m-%dT%H:%M:%SZ" + (Calendar.Precise.from_unixfloat ft) -type 'a timed_data = { - data: 'a ; - time: t ; -} + let rfc_encoding = + let open Data_encoding in + def + "timestamp" @@ + describe + ~title: + "RFC 3339 formatted timestamp" + ~description: + "A date in human readble form as specified in RFC 3339." @@ + conv + to_notation + (fun s -> match of_notation s with + | Some s -> s + | None -> Data_encoding.Json.cannot_destruct "Time.of_notation") + string -let timed_encoding arg_encoding = - let open Data_encoding in - conv - (fun {time; data} -> (time, data)) - (fun (time, data) -> {time; data}) - (tup2 encoding arg_encoding) + let encoding = + let open Data_encoding in + splitted + ~binary: int64 + ~json: + (union [ + case + rfc_encoding + (fun i -> Some i) + (fun i -> i) ; + case + int64 + (fun _ -> None) + (fun i -> i) ; + ]) -let make_timed data = { - data ; time = now () ; -} + type 'a timed_data = { + data: 'a ; + time: t ; + } -let pp_hum ppf t = Format.pp_print_string ppf (to_notation t) + let timed_encoding arg_encoding = + let open Data_encoding in + conv + (fun {time; data} -> (time, data)) + (fun (time, data) -> {time; data}) + (tup2 encoding arg_encoding) + + let make_timed data = { + data ; time = now () ; + } + + let pp_hum ppf t = Format.pp_print_string ppf (to_notation t) +end + +include T +module Set = Set.Make(T) +module Map = Map.Make(T) +module Table = Hashtbl.Make(T) diff --git a/src/utils/time.mli b/src/utils/time.mli index 8d209894e..7498899e5 100644 --- a/src/utils/time.mli +++ b/src/utils/time.mli @@ -9,6 +9,10 @@ type t +val min_value : t +val epoch : t +val max_value : t + val add : t -> int64 -> t val diff : t -> t -> int64 @@ -46,3 +50,7 @@ type 'a timed_data = { val make_timed : 'a -> 'a timed_data val timed_encoding : 'a Data_encoding.t -> 'a timed_data Data_encoding.t + +module Set : Set.S with type elt = t +module Map : Map.S with type key = t +module Table : Hashtbl.S with type key = t