Source file datetime.ml

(*********************************************************************************)
(*                OCaml-Stk                                                      *)
(*                                                                               *)
(*    Copyright (C) 2023-2024 INRIA All rights reserved.                         *)
(*    Author: Maxence Guesdon, INRIA Saclay                                      *)
(*                                                                               *)
(*    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                                          *)
(*                                                                               *)
(*********************************************************************************)

(** Widgets for date and time display and edition. *)

module PPair_int = Props.PPair(Props.PInt)(Props.PInt)

(** A month is (year * month (1..12)) *)
type month = int * int

(** Property used to store the month displayed by a calendar. *)
let p_month : month Props.prop = PPair_int.mk_prop ~after:[Props.Resize]
  ~inherited:false "month"

module PDate = Props.PTriple(Props.PInt)(Props.PInt)(Props.PInt)
module PDates = Props.PList(PDate)

(** Date time, in the form (year, month(1..12), day(1..31)).*)
type date = int * int * int

let p_selected_dates : date list Props.prop = PDates.mk_prop ~after:[Props.Resize]
  ~default:[] ~inherited:false "selected_dates"

type _ Events.ev +=
| Date_selected : (date -> unit) Events.ev
| Date_unselected : (date -> unit) Events.ev

type weekday = [ `Mon | `Tue | `Wed | `Thu | `Fri | `Sat | `Sun ]
let wdays =
    [| "Monday" ; "Tuesday" ; "Wednesday" ;
       "Thursday" ; "Friday" ; "Saturday" ; "Sunday" |]

let months = [|
   "January" ; "February" ; "March" ; "April" ; "May" ; "June" ;
   "July" ; "August" ; "September" ; "October" ; "November" ; "December" |]

let array_get_opt i t =
  if i < Array.length t then Some t.(i) else None

let string_of_weekday_int i =
  match array_get_opt i wdays with
  | None -> failwith (Printf.sprintf "invalid week day %d" i)
  | Some str -> str

let int_of_weekday = function
| `Mon -> 0 | `Tue -> 1 | `Wed -> 2 | `Thu -> 3
| `Fri -> 4 | `Sat -> 5 | `Sun -> 6

let weekday_of_int = function
| 0 -> `Mon | 1 -> `Tue | 2 -> `Wed | 3-> `Thu
| 4 -> `Fri | 5 -> `Sat | 6 -> `Sun
| n -> failwith (Printf.sprintf "Invalid week day %d" n)

let string_of_weekday (wd:weekday) = string_of_weekday_int (int_of_weekday wd)

let short_string_of_weekday_int i = String.sub (string_of_weekday_int i) 0 2
let short_string_of_weekday (wd:weekday) =  short_string_of_weekday_int (int_of_weekday wd)

let string_of_month i =
  match array_get_opt (i-1) months with
  | None -> failwith (Printf.sprintf "invalid month %d" i)
  | Some str -> str

let today () =
  Ptime.to_date (
   match Ptime.of_float_s (Unix.gettimeofday ()) with
   | None -> Ptime.epoch
   | Some d -> d
  )

class calendar ?(class_="calendar") ?name ?props ?wdata () =
  let box_title = Pack.hbox ~classes:[class_^"_box_title"] () in
  let (bprev,_) = Button.text_button ~classes:[class_^"_button"]
    ~text:"◀" ~pack:(box_title#pack ~hexpand:0) ()
  in
  let title = Text.label ~classes:[class_^"_title"] ~pack:box_title#pack () in
  let (bnext,_) = Button.text_button ~classes:[class_^"_button"]
    ~text:"▶" ~pack:(box_title#pack ~hexpand:0) ()
  in
  let cal = Table.table ~classes:[class_^"_table"] ~rows:1 ~columns:7 () in
  object(self)
    inherit [unit] Pack.box ~classes:[class_] ?name ?props ?wdata () as super

    (**/**)

    val mutable day_widgets : (Text.label * Button.button * weekday) array = [| |]

    (**/**)

    (** {2 Properties} *)

    method month : month = self#get_p p_month
    method set_month : ?delay:float -> ?propagate:bool -> month -> unit = self#set_p p_month

    (** [cal#prev_month] changes the {!p_month} property to previous
      month, if this property was set. *)
    method prev_month =
      match self#opt_p p_month with
      | None -> ()
      | Some (y,m) when m <= 1 -> self#set_month (y-1, 12)
      | Some (y,m) -> self#set_month (y, min 12 (m-1))

    (** [cal#next_month] changes the {!p_month} property to next
      month, if this property was set. *)
    method next_month =
      match self#opt_p p_month with
      | None -> ()
      | Some (y,m) when m >= 12 -> self#set_month (y+1, 1)
      | Some (y,m) -> self#set_month (y,max 1 (m+1))

    method editable = self#get_p Props.editable
    method set_editable = self#set_p Props.editable

    method selected_dates = self#get_p p_selected_dates

    (**/**)

    method private set_selected_dates = self#set_p p_selected_dates

    (**/**)

    method selection_mode = self#get_p Props.selection_mode
    method set_selection_mode = self#set_p Props.selection_mode

    (** {2 Hacking} *)

    (** [cal#clear] removes all day widgets. *)
    method clear =
      for row = 1 to cal#rows do
        for column = 0 to cal#columns do
          cal#unpack_at ~destroy:true ~row ~column
        done
      done;
      day_widgets <- [| |]

    (** [cal#set_title str] changes title of calendar. Beware the title
       is also set when the month changes. *)
    method set_title (y,m) =
      let mon = string_of_month m in
      let str = Printf.sprintf "%s %04d" mon y in
      title#set_text str

    (**/**)

    method private insert_blank pos =
      ignore(Text.label ~classes:[class_^"_day"] ~pack:(cal#pack ~pos) ())

    method private mk_day wd ((y,m,day) as date) =
      let on_key_pressed kev =
        let key = kev.Widget.key in
        let day2 =
          match key with
          | k when k = Tsdl.Sdl.K.up -> Some (day - 7)
          | k when k = Tsdl.Sdl.K.down -> Some (day + 7)
          | k when k = Tsdl.Sdl.K.left -> Some (day - 1)
          | k when k = Tsdl.Sdl.K.right -> Some (day + 1)
          | _ -> None
        in
        match day2 with
        | Some d when self#valid_day ~err:false d ->
            let (_,b,_) = day_widgets.(d-1) in
            b#grab_focus()
        | _ -> false
      in
      let b = Button.button ~classes:[class_^"_day_button"] () in
      let _ = b#connect Widget.Key_pressed on_key_pressed in
      let l = Text.label ~classes:[class_^"_day"]
        ~pack:b#set_child
        ~text:(string_of_int day)  ()
      in
      l#set_handle_hovering false ;
      let _ = b#connect Widget.Activated
        (fun ()-> self#on_day_activated l day)
      in
      l#set_selected (List.mem date self#selected_dates);
      (l, b, weekday_of_int wd)

    method private weekday_of_date date =
      match Ptime.of_date date with
      | None -> None
      | Some pt ->
          let wd = Ptime.weekday_num pt in
          (* 0 is monday for us, but sunday in ptime *)
          let wd = (wd + 6) mod 7 in
          Some wd

    method private fill_days (y,m) =
      let next_day = ref 0 in
      let rec iter acc i =
        match self#weekday_of_date (y,m,i) with
        | None ->
            (* add blanks until end of week *)
            let acc =
              if !next_day > 0 then
                (List.init (7 - !next_day) (fun _ -> None)) @ acc
              else
                acc
            in
            List.rev acc
        | Some wd ->
            let acc =
              if wd <> !next_day then
                (* must fill prevous days with blanks *)
                (List.init (wd - !next_day) (fun _ -> None)) @ acc
              else
                acc
            in
            let widgets = self#mk_day wd (y,m,i) in
            next_day := (wd + 1) mod 7;
            iter ((Some widgets)::acc) (i+1)
      in
      let list = iter [] 1 in
      let len = List.length list in
      cal#set_rows (1 + (len / 7) + (if len mod 7 = 0 then 0 else 1)) ;
      let rec insert acc i = function
      | [] -> Array.of_list (List.rev acc)
      | None :: q ->
          self#insert_blank (1 + i/7, i mod 7);
          insert acc (i+1) q
      | (Some ((l,b,_) as x)) :: q ->
          cal#pack ~pos:(1 + i/7, i mod 7) b#coerce;
          insert (x::acc) (i+1) q
      in
      day_widgets <- insert [] 0 list

    method private on_month_changed ~prev ~now =
      let old = ignore_need_resize in
      self#ignore_need_resize ;
      self#clear;
      self#set_title now ;
      self#fill_days now ;
      if not old then self#handle_need_resize;
      cal#need_resize;
      self#need_resize

    method private valid_date ?(err=true) ((y,m,d) as date) =
      match self#weekday_of_date date with
      | None ->
          if err then Log.err (fun p -> p "%s: invalid date (%04d,%02d,%02d)"
            self#me y m d);
          false
      | Some _ -> true

    method private valid_day ?(err=true) ?(tip="") day =
      let len = Array.length day_widgets in
      if day <= 0 || day > len then
        (
         if err then Log.err (fun m -> m "%s%s: invalid day %d (day_widgets has length %d)"
            self#me tip day len);
         false
        )
      else
        true

    (**/**)

    (** [cal#day_label n] returns the label widget corresponding to the given
     month day (1..<last day of month>).*)
    method day_label day =
      if self#valid_day day
      then  let (lab,_,_) = day_widgets.(day-1) in Some lab
      else None


    (** [cal#day_labels_of_weekday wd] returns the list of label widgets
      for the given weekday. *)
    method day_labels_of_weekday wd =
      let l = ref [] in
      Array.iteri (fun day (lab,_,w) -> if w = wd then l := (day, lab) :: !l) day_widgets;
      List.rev !l

    (** {2 Selection} *)

    method select_date ?(only=false) ((y,m,d) as date) =
      match self#valid_date ~err:true date with
      | false -> ()
      | true ->
          match self#selection_mode with
          | Props.Sel_none -> ()
          | sel_mode ->
              let old_sel = self#selected_dates in
              if only || sel_mode <> Sel_multiple then
                List.iter self#unselect_date_ self#selected_dates;
              self#set_selected_dates (date :: self#selected_dates) ;
              if not (old_sel = self#selected_dates) then
                ((match self#opt_p p_month with
                 | Some (cy,cm) when cy = y && cm = m ->
                      let (lab,_,_) = day_widgets.(d-1) in
                      (lab  :> Widget.widget)#set_selected true
                  | _ -> ()
                 );
                 self#trigger_unit_event Date_selected date
                )

    method private unselect_date_ ((y,m,d) as date) =
      if self#valid_date date then
        (
         let old_sel = self#selected_dates in
         self#set_selected_dates (List.filter ((<>) date) self#selected_dates);
         if not (old_sel = self#selected_dates) then
           ((match self#opt_p p_month with
             | Some (cy,cm) when cy = y && cm = m ->
                 let (lab,_,_) = day_widgets.(d-1) in
                 lab#set_selected false
             | _ -> ()
            );
            self#trigger_unit_event Date_unselected date
           )
        )

    method unselect_date date =
      match self#selection_mode with
      | Sel_browse -> ()
      | Sel_none -> ()
      | _ -> self#unselect_date_ date

    method unselect_all =
      List.iter self#unselect_date_ self#selected_dates

    (**/**)

    method private select_or_unselect_day day =
      match self#opt_p p_month with
      | None -> ()
      | Some (y,m) ->
          let date = (y,m,day) in
          if self#valid_date date then
            if List.mem date self#selected_dates then
              if Key.is_mod_pressed Tsdl.Sdl.Kmod.ctrl then
                self#unselect_date date
              else
                ()
            else
              let only = not (Key.is_mod_pressed Tsdl.Sdl.Kmod.ctrl) in
              self#select_date ~only date

    method private on_day_activated label day =
      self#select_or_unselect_day day

    method on_editable_changed ~prev ~now =
      bprev#set_visible now;
      bnext#set_visible now

    method! on_key_down pos event key mods =
      [%debug "%s#on_key_down: %s" self#me (Tsdl.Sdl.get_key_name key)];
      self#editable && match key with
      | k when k = Tsdl.Sdl.K.pageup && self#editable -> self#prev_month; true
      | k when k = Tsdl.Sdl.K.pagedown && self#editable -> self#next_month; true
      | _ -> false

    method private on_mouse_wheel ev =
      let y = Tsdl.Sdl.Event.(get ev mouse_wheel_y) in
      if y < 0 then self#next_month else if y > 0 then self#prev_month

    method! on_sdl_event coords ev =
      let b =
        if not self#visible then
          false
        else
          match Tsdl.Sdl.Event.(enum (get ev typ)) with
          | `Mouse_wheel when self#editable -> (self#on_mouse_wheel ev; true)
          | _ -> false
      in
      b || super#on_sdl_event coords ev

    initializer
      self#set_orientation Props.Vertical;
      self#pack ~vexpand:0 box_title#coerce ;
      self#pack cal#coerce ;
      let _ = self#connect (Object.Prop_changed p_month) self#on_month_changed in
      let _ = self#connect (Object.Prop_changed Props.editable) self#on_editable_changed in
      bprev#set_visible self#editable ;
      bnext#set_visible self#editable ;
      bprev#connect Widget.Activated (fun () -> self#prev_month);
      bnext#connect Widget.Activated (fun () -> self#next_month);
      for i = 0 to 6 do
        let _label = Text.label ~classes:[class_^"_weekday"]
          ~text:(short_string_of_weekday_int i) ~pack:(cal#pack ~vexpand:0 ~pos:(0,i)) ()
        in
        ()
      done
  end

let calendar ?class_ ?name ?props ?wdata ?pack () =
  let w = new calendar ?class_ ?name ?props ?wdata () in
  Widget.may_pack ?pack w ;
  w

let dialog_calendar ?classes ?cal_class ?behaviour ?flags ?rflags ?resizable ?x ?y ?w ?h
  ?(selected_dates=[]) ?(allow_multiple=false) title =
  let d = Dialog.dialog ?classes ?behaviour ?flags ?rflags ?resizable ?x ?y ?w ?h title in
  let (y,m,_) =
    match selected_dates with
    | [] -> today ()
    | h::q -> List.fold_right (fun d acc -> max d acc) q h
  in
  let cal = calendar ?class_:cal_class ~pack:d#content_area#set_child () in
  cal#set_month (y,m);
  List.iter cal#select_date selected_dates ;
  cal#set_selection_mode (if allow_multiple then Props.Sel_multiple else Props.Sel_single);
  d, cal

let dialog_select_date ?classes ?cal_class ?behaviour ?flags ?rflags ?resizable ?x ?y ?w ?h
  ?(ok="Ok") ?(cancel="Cancel")
  ?selected_date title =
  let (d,cal) = dialog_calendar ?classes ?cal_class ?behaviour ?flags ?rflags ?resizable ?x ?y ?w ?h
    ~selected_dates:(match selected_date with None -> [] | Some d -> [d]) title
  in
  let _bok = d#add_text_button
    ~return:(fun () ->
       match cal#selected_dates with [] -> Some None | h::_ -> Some (Some h))
    ~ks:(Key.keystate Tsdl.Sdl.K.return) ok
  in
  let _bcancel = d#add_text_button
    ~return:(fun () -> None)
    ~ks:(Key.keystate Tsdl.Sdl.K.escape) cancel
  in
  d,cal

let dialog_select_dates ?classes ?cal_class ?behaviour ?flags ?rflags ?resizable ?x ?y ?w ?h
  ?(ok="Ok") ?(cancel="Cancel")
  ?selected_dates title =
  let (d,cal) = dialog_calendar ?classes ?cal_class ?behaviour ?flags ?rflags ?resizable ?x ?y ?w ?h
    ?selected_dates title
  in
  let _bok = d#add_text_button
    ~return:(fun () -> Some cal#selected_dates)
    ~ks:(Key.keystate Tsdl.Sdl.K.return) ok
  in
  let _bcancel = d#add_text_button
    ~return:(fun () -> None)
    ~ks:(Key.keystate Tsdl.Sdl.K.escape) cancel
  in
  d,cal

type Widget.wdata += Date of date

(** Property used in {!date_label} to indicate whether no date can be selected.*)
let p_allow_none = Props.bool_prop ~inherited:false ~default:true "date-allow-none"

let date_label ?classes ?name ?props ?date ?allow_none ?pack ?(button_text="..") () =
  let hbox = Pack.hbox () in
  let label = Text.label ?classes ?name ?props ~pack:(hbox#pack ~hexpand:0) () in
  Option.iter (label#set_p p_allow_none) allow_none;
  let wb,_ = Button.text_button ~text:button_text ~pack:(hbox#pack ~hexpand:0) () in
  let label_date () =
    match label#wdata with
    | Some (Date d) -> Some d
    | _ -> None
  in
  let update_label () =
    match label_date () with
    | None -> label#set_text ""
    | Some (y,m,d) -> label#set_text (Printf.sprintf "%04d/%02d/%02d" y m d)
  in
  let set_date =
    let prev_date = ref None in
    fun d ->
      (match d with
       | Some date ->
           prev_date := Some date;
           label#set_wdata (Some (Date date))
       | None ->
           let d =
             match label#get_p p_allow_none with
             | true -> None
             | false -> !prev_date
           in
           let wd = Option.map (fun d -> Date d) d in
           label#set_wdata wd
    );
    update_label ()
  in
  set_date date;
  let select_date () =
    match hbox#top_window with
    | None -> ()
    | Some w ->
        let selected_date = label_date () in
        let behaviour =
          match App.window_from_sdl (Tsdl.Sdl.get_window_id w) with
          | None -> None
          | Some (w,_) -> Some (`Modal_for w)
        in
        let d,_cal = dialog_select_date ?behaviour
          ~resizable:true ~w:200 ~h:200 ?selected_date "Select date" in
        d#run_async (function
         | None -> Lwt.return_unit
         | Some d -> set_date d; Lwt.return_unit)
  in
  let _ = wb#connect Widget.Activated select_date in
  Widget.may_pack ?pack hbox ;
  (label,label_date,set_date,hbox)