mte/src/time.ml

let uint64_max = Int64.minus_one

module TimeRelative = struct
  type t = Int64.t

  let forever = uint64_max
  let zero = 0L
  let compare = Int64.unsigned_compare
  let min a b = if compare a b < 0 then a else b
  let max a b = if compare a b > 0 then a else b

  (* forever if either argument is forever or on overflow; otherwise a + b *)
  let add a b =
    if a = forever || b = forever then forever
    else
      let v = Int64.add a b in
      if compare v a < 0 then forever else v

  (* zero if a <= b, or forever if a is forever; otherwise a - b *)
  let sub a b =
    if compare a b <= 0 then zero
    else if a = forever then forever
    else Int64.sub a b

  let of_s s =
    let v = Int64.mul s 1_000_000L in
    if Int64.unsigned_div v 1_000_000L <> s then forever else v

  let bin = Bin.beint64

  let caqti =
    let encode v = Ok v in
    let decode v = Ok v in
    Caqti_type.custom ~encode ~decode Caqti_type.int64

  (* TODO
     reject negative / non-integer values
     cap value at 2^53 - 1 inclusive *)
  let jsont =
    let jsont =
      let forever_jsont =
        let dec s =
          match s with
          | "forever" -> forever
          | _ -> Jsont.Error.msg Jsont.Meta.none "unexpected string value"
        in
        let enc _t = "forever" in
        Jsont.map ~dec ~enc Jsont.string
      in
      let num_jsont = Jsont.int64 in
      let enc t = if t = forever then forever_jsont else num_jsont in
      Jsont.any ~dec_string:forever_jsont ~dec_number:num_jsont ~enc ()
    in
    Jsont.Object.map ~kind:"RelativeTime" Fun.id
    |> Jsont.Object.mem "d_us" jsont ~enc:Fun.id
    |> Jsont.Object.finish
end

module TimeAbsolute = struct
  type t = Int64.t

  let never = uint64_max
  let zero = 0L
  let compare = Int64.unsigned_compare
  let min a b = if compare a b < 0 then a else b
  let max a b = if compare a b > 0 then a else b

  (* zero if a >= b; never if b=never; otherwise b - a *)
  let diff a b =
    if compare a b >= 0 then zero
    else if b = never then never
    else Int64.sub b a

  (* never if either argument is never/forever or on overflow; otherwise t + d *)
  let add t d =
    if t = never || d = never then never
    else
      let v = Int64.add t d in
      if compare v t < 0 then never else v

  (* zero if t <= d, or never if t is never; otherwise t - d *)
  let sub t d =
    if compare t d <= 0 then zero
    else if t = never then never
    else Int64.sub t d

  let of_s s =
    let v = Int64.mul s 1_000_000L in
    if Int64.unsigned_div v 1_000_000L <> s then never else v

  let of_ptime v = v |> Ptime.to_float_s |> Int64.of_float |> of_s
end

module Timestamp = struct
  type t = Int64.t

  let never = uint64_max
  let zero = 0L
  let compare = Int64.unsigned_compare
  let gt a b = compare a b > 0
  let geq a b = compare a b >= 0
  let lt a b = compare a b < 0
  let leq a b = compare a b <= 0
  let equal a b = compare a b = 0
  let min a b = if compare a b < 0 then a else b
  let max a b = if compare a b > 0 then a else b

  (* zero if a >= b; never if b=never; otherwise b - a *)
  let diff a b =
    if compare a b >= 0 then zero
    else if b = never then never
    else Int64.sub b a

  let of_s s =
    let v = Int64.mul s 1_000_000L in
    if Int64.unsigned_div v 1_000_000L <> s then never else v

  let to_s t =
    if t = never then None else Some (Int64.unsigned_div t 1_000_000L)

  let of_absolute a =
    if a = never then never else Int64.sub a (Int64.unsigned_rem a 1_000_000L)

  let of_ptime v = v |> TimeAbsolute.of_ptime |> of_absolute
  let bin = Bin.beint64

  let caqti =
    let encode v = Ok v in
    let decode v = Ok v in
    Caqti_type.custom ~encode ~decode Caqti_type.int64

  let jsont =
    let jsont =
      let never_jsont =
        let dec s =
          match s with
          | "never" -> never
          | _ -> Jsont.Error.msg Jsont.Meta.none "unexpected string value"
        in
        let enc _t = "never" in
        Jsont.map ~dec ~enc Jsont.string
      in
      let num_jsont =
        Jsont.map
          ~dec:(fun n -> of_s n)
          ~enc:(fun t -> match to_s t with None -> assert false | Some s -> s)
          Jsont.int64
      in
      let enc t = if t = never then never_jsont else num_jsont in
      Jsont.any ~dec_string:never_jsont ~dec_number:num_jsont ~enc ()
    in
    Jsont.Object.map ~kind:"Timestamp" Fun.id
    |> Jsont.Object.mem "t_s" jsont ~enc:Fun.id
    |> Jsont.Object.finish
end