Source file period.ml

(*********************************************************************************)
(*                Statocaml                                                      *)
(*                                                                               *)
(*    Copyright (C) 2025 INRIA All rights reserved.                              *)
(*    Author: Maxence Guesdon (INRIA Saclay)                                     *)
(*      with Gabriel Scherer (INRIA Paris) and Florian Angeletti (INRIA Paris)   *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU General Public License as                    *)
(*    published by the Free Software Foundation, version 3 of the License.       *)
(*                                                                               *)
(*    This program is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the               *)
(*    GNU General Public License for more details.                               *)
(*                                                                               *)
(*    You should have received a copy of the GNU General Public                  *)
(*    License along with this program; if not, write to the Free Software        *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    As a special exception, you have permission to link this program           *)
(*    with the OCaml compiler and distribute executables, as long as you         *)
(*    follow the requirements of the GNU GPL in regard to all of the             *)
(*    software in the executable aside from the OCaml compiler.                  *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

type t = All
  | Year of int
  | YInterval of int * int
  | DInterval of Types.date * Types.date * string option

let compare p1 p2 =
  match p1, p2 with
  | All, All -> 0
  | All, _ -> 1
  | _, All -> -1
  | YInterval (y1,y2), YInterval (y3,y4) ->
      (match Int.compare y1 y3 with
       | 0 -> Int.compare y2 y4
       | n -> n)
  | YInterval _, _ -> 1
  | _, YInterval _ -> -1
  | DInterval (d1,d2,s1), DInterval (d3,d4,s2) ->
      (match Types.compare_date d1 d3 with
       | 0 ->
           (match Types.compare_date d2 d4 with
            | 0 -> Option.compare String.compare s1 s2
            | n -> n
           )
       | n -> n
      )
  | DInterval _, _ -> 1
  | _, DInterval _ -> -1
  | Year y1, Year y2 -> Int.compare y1 y2

let to_string = function
| All -> "all"
| Year y -> string_of_int y
| YInterval (y1, y2) -> Printf.sprintf "%d-%d" y1 y2
| DInterval (_,_, Some s) -> s
| DInterval (d1, d2, None) ->
    let to_s = Types.string_of_date in
    Printf.sprintf "%s-%s" (to_s d1) (to_s d2)

let pp ppf p = Format.pp_print_string ppf (to_string p)

module Ordered = struct type nonrec t = t let compare = compare end
module Map = Map.Make(Ordered)
module Set = Set.Make(Ordered)

type gen =
| Until_by_days of Types.date * int (* stop date * days in each period *)
| Until_by_month of Types.date (* stop date, each period is a month *)

let mk_dintervals_by_days ~start ~stop days =
  let ptime_stop = Types.ptime_of_date stop in
  let span = Ptime.Span.of_int_s (24 * 3600 * days) in
  let rec iter acc start =
    if Ptime.compare start ptime_stop >= 0 then
      List.rev acc
    else
      match Ptime.add_span start span with
      | None -> failwith "mk_dintervals_by_days"
      | Some next_start ->
          let next_start = Types.ptime_min next_start ptime_stop in
          let p = DInterval (Types.date_of_ptime start, Types.date_of_ptime next_start, None) in
          iter (p::acc) next_start
  in
  iter [] (Types.ptime_of_date start)

let leap_year y = (y mod 4 = 0) && ((not (y mod 100 = 0)) || (y mod 400 = 0))

let mk_dintervals_by_month ~start ~stop =
  let rec iter acc start =
    if Types.compare_date start stop >= 0 then
      List.rev acc
    else
      let (y,m,d) = start in
      let next_start =
        let (y2,m2) = Types.next_month (y,m) in
        (y2,m2,1)
      in
      let p = DInterval (start, next_start, None) in
      iter (p::acc) next_start
  in
  iter [] start

let mk_years ~start ~stop =
  let rec iter acc y =
    if Types.compare_date y stop > 0 then
      List.rev acc
    else
      let p = Year y in
      iter (p::acc) (y+1)
  in
  iter [] start

let date_in_period = function
| All -> (fun _ -> true)
| Year y -> (fun (y2,_,_) -> y = y2)
| YInterval (y1, y2) -> (fun (y,_,_) -> y >= y1 && y <= y2) (* y2 is part of interval *)
| DInterval (d1, d2, _) -> (* d2 is not part of interval *)
    (fun d -> Types.compare_date d d1 >= 0 && Types.compare_date d d2 < 0)

let ptime_bounds = function
| All -> None
| Year y ->
    let start = Types.ptime_of_date (y,1,1) in
    let stop = Types.ptime_of_date (y+1,1,1) in
    Some (start, stop)
| YInterval (y1, y2) ->
    let start = Types.ptime_of_date (y1,1,1) in
    let stop = Types.ptime_of_date (y2+1,1,1) in
    Some (start, stop)
| DInterval (d1, d2, _) ->
    let start = Types.ptime_of_date d1 in
    let stop = Types.ptime_of_date d2 in
    Some (start, stop)

let ptime_in_period p =
  let in_period = date_in_period p in
  fun d -> in_period (Types.date_of_ptime d)