Source file duration.ml

(* Copyright (c) 2026, Cargocut and the Lunar developers.
   All rights reserved.

   SPDX-License-Identifier: BSD-3-Clause *)

type t = int64

let zero = Int64.zero
let one = Int64.one
let from_int64 x = x
let from_seconds = Int64.of_int
let from_minutes x = x |> from_seconds |> Int64.mul 60L
let from_hours x = x |> from_seconds |> Int64.mul 3600L
let from_days x = x |> from_seconds |> Int64.mul 86400L
let one_day = from_days 1
let one_minute = from_minutes 1
let one_hour = from_hours 1
let abs = Int64.abs
let neg x = Int64.(sub zero x)

let div_floor a b =
  let q = a / b
  and r = a mod b in
  if (not (Int.equal 0 r)) && not (Bool.equal (r > 0) (b > 0))
  then pred q
  else q
;;

let gregorian_cycle = 146097
let epoch_shift = 719468

let days_from_civil year month day =
  (* NOTE: This the Howard Hinnant’s "civil calendar" algorithms.
     See: https://howardhinnant.github.io/date/date.html *)
  let year = if month <= 2 then pred year else year in
  let era = div_floor year 400 in
  let y = year - (era * 400) in
  let m = if month > 2 then month - 3 else month + 9 in
  let d = (y * 365) + (y / 4) - (y / 100) + ((((153 * m) + 2) / 5) + day - 1) in
  (era * gregorian_cycle) + d - epoch_shift
;;

let civil_from_days d =
  (* NOTE: This the Howard Hinnant’s dual "civil calendar" algorithms.
     See: https://howardhinnant.github.io/date/date.html *)
  let shift = d + epoch_shift in
  let era = div_floor shift gregorian_cycle in
  let day_of_era = shift - (era * gregorian_cycle) in
  let year_of_era =
    (day_of_era
     - (day_of_era / 1460)
     + (day_of_era / 36524)
     - (day_of_era / 146096))
    / 365
  in
  let year = year_of_era + (era * 400) in
  let day_of_year =
    day_of_era - ((365 * year_of_era) + (year_of_era / 4) - (year_of_era / 100))
  in
  let m = ((5 * day_of_year) + 2) / 153 in
  let day = day_of_year - (((153 * m) + 2) / 5) + 1 in
  let month = if m < 10 then m + 3 else m - 9 in
  let year = if month <= 2 then year + 1 else year in
  year, month, day
;;

let from_datetime ~year ~month ~day ~hour ~min ~sec =
  let days = days_from_civil year month day |> from_days in
  days
  |> Int64.add (from_hours hour)
  |> Int64.add (from_minutes min)
  |> Int64.add (from_seconds sec)
;;

let to_datetime duration =
  let days = one_day |> Int64.div duration |> Int64.to_int in
  let rem_secs = one_day |> Int64.rem duration |> Int64.to_int in
  let days, rem_secs =
    if rem_secs < 0
    then days - 1, rem_secs + Int64.to_int one_day
    else days, rem_secs
  in
  let year, month, day = civil_from_days days in
  let hour = rem_secs / 3600
  and min = rem_secs mod 3600 / 60
  and sec = rem_secs mod 60 in
  year, month, day, hour, min, sec
;;

let to_int64 x = x
let compare = Int64.compare
let equal = Int64.equal
let add = Int64.add
let sub = Int64.sub
let mul ts x = Int64.(mul ts (of_int x))
let succ = Int64.succ
let pred = Int64.pred

let wdhms x =
  let weeks, rem = Util.i64_div_mod_floor x (from_days 7) in
  let days, rem = Util.i64_div_mod_floor rem one_day in
  let hour, rem = Util.i64_div_mod_floor rem one_hour in
  let min, sec = Util.i64_div_mod_floor rem one_minute in
  (* MAYBE: an opportunity for labelled-tuple. *)
  ( Int64.to_int weeks
  , Int64.to_int days
  , Int64.to_int hour
  , Int64.to_int min
  , Int64.to_int sec )
;;

let dhms x =
  let days, rem = Util.i64_div_mod_floor x one_day in
  let hour, rem = Util.i64_div_mod_floor rem one_hour in
  let min, sec = Util.i64_div_mod_floor rem one_minute in
  (* MAYBE: an opportunity for labelled-tuple. *)
  Int64.to_int days, Int64.to_int hour, Int64.to_int min, Int64.to_int sec
;;

let hms x =
  let hours, rem = Util.i64_div_mod_floor x one_hour in
  let min, sec = Util.i64_div_mod_floor rem one_minute in
  (* MAYBE: an opportunity for labelled-tuple. *)
  Int64.to_int hours, Int64.to_int min, Int64.to_int sec
;;

let weekday x =
  let weekdays = Weekday.[| Sun; Mon; Tue; Wed; Thu; Fri; Sat |] in
  let d, _, _, _ = dhms x in
  let id = (d + 4) mod 7 in
  weekdays.((id + 7) mod 7)
;;

let to_seconds t = t |> to_int64 |> Int64.to_int
let to_minutes t = Int64.(to_int (div t one_minute))
let to_hours t = Int64.(to_int (div t one_hour))
let to_days t = Int64.(to_int (div t one_day))

module CE = struct
  type nonrec t = t

  let equal = equal
  let compare = compare
end

module Infix = struct
  let ( + ) = Int64.add
  let ( - ) = Int64.sub
  let ( * ) = mul

  include Util.Make_equal_infix (CE)
  include Util.Make_compare_infix (CE)
end

include Util.Make_compare_helpers (CE)
include Infix