Shell: add Time.{Map,Set,Table}
This commit is contained in:
Vincent Bernardoff
Grégoire Henry
parent
a891e23741
commit
ad035d7679
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user