Source file app.ml

open Misc
open Tsdl

[@@@landmark "auto"]

let ( >>= ) = Lwt.( >>= )

type sdl_events_mode = [`Detached | `Lwt_engine]

let renderer_flag_env_var = "STK_APP_RENDERER_FLAGS"
let renderer_flag_of_string str =
  Sdl.Renderer.
    (match String.lowercase_ascii str with
     | "software" -> software
     | "accelerated" -> accelerated
     | "presentvsync" -> presentvsync
     | "targettexture" -> targettexture
     | _ ->
         failwith (Printf.sprintf
          "%s: Unsupported renderer flag %S"
           renderer_flag_env_var str)
    )

let default_app_renderer_flags =
  match Sys.getenv_opt renderer_flag_env_var with
  | None | Some "" -> None
  | Some s ->
      try
        let l = List.filter (function "" -> false | _ -> true)
          (String.split_on_char ',' s)
        in
        match l with
        | [] -> None
        | h::q ->
            let flags =
              List.fold_left
                (fun acc s -> Sdl.Renderer.(+) acc (renderer_flag_of_string s))
                (renderer_flag_of_string h) q
            in
            Some flags
      with
      | Failure s -> prerr_endline s; exit 1

type app =
  {
    window_flags : Sdl.Window.flags option ;
    renderer_flags : Sdl.Renderer.flags option ;
    mutable event_delay : int ;
    mutable windows : Window.window Misc.IMap.t ;
    mutable menu_windows : (int * Window.window) list ;
    mutable running : (unit Lwt.t * unit Lwt.u) option ;
    sdl_events_mode : sdl_events_mode ;
  }

let app = ref None

let check_sdl_events_cb = ref (fun (_:app) (_:Lwt_engine.event) -> ())

let init ?(force_mouse_focus_clickthrough=true)
  ?window_flags ?(renderer_flags=default_app_renderer_flags)
   ?(event_delay=10)
  ?(sdl_events_mode=`Lwt_engine) () =
  if force_mouse_focus_clickthrough then
    ignore(Sdl.(set_hint_with_priority Hint.mouse_focus_clickthrough "1" Hint.override));
  Tsdl_ttf.Ttf.init ();
  let%lwt () = Font.load_fonts ()  in
  Font.add_fallback_font 0x1f600 0x1f64f "DejaVu Sans";
  Theme.init ();
  Texttag.Theme.init ();
  Log.debug (fun m -> m
    "default theme: %s" (Theme.(to_string (current()))));
  let a =
    { window_flags ;
      renderer_flags ;
      event_delay ;
      windows = Misc.IMap.empty ;
      menu_windows = [] ;
      running = None ;
      sdl_events_mode ;
    }
  in
  app := Some a;

  (* in `Lwt_engine mode, register event-handling in lwt, through a timer *)
  (match sdl_events_mode with
   | `Detached -> ()
   | `Lwt_engine ->
       ignore(Lwt_engine.on_timer
         ((float a.event_delay) /. 1000.) true
         (!check_sdl_events_cb a))
  );
  Lwt.return_unit

let app () =
  match !app with
  | None -> failwith "Stk app not initialized"
  | Some a -> a

let create_window ?modal_for ?flags ?rflags ?resizable ?show ?x ?y ?w ?h title =
  let app = app () in
  let flags = match flags with
    | None -> app.window_flags
    | o -> o
  in
  let rflags = match rflags with
    | None -> app.renderer_flags
    | o -> o
  in
  let win = Window.window ?flags ?rflags ?resizable ?show ?x ?y ?w ?h title in
  app.windows <- IMap.add win#window_id win app.windows;
  let on_close () =
    (*prerr_endline (Printf.sprintf "removing window %d" win#window_id);*)
    app.windows <- IMap.remove win#window_id app.windows
  in
  win#set_on_close on_close ;
  (
   match modal_for with
   | None -> ()
   | Some (parent:Window.window) ->
       let was_sensitive = parent#sensitive in
       parent#set_sensitive false ;
       let _ = win#connect Widget.Destroy
         (fun () -> parent#set_sensitive was_sensitive; false) in
       let> () = Sdl.set_window_modal_for ~modal:win#window ~parent:parent#window in
       ()
  );
  win

let create_scrolled_window ?modal_for ?flags ?rflags ?resizable ?show ?x ?y ~w ~h
  ?hpolicy ?vpolicy title =
  let win = create_window ?modal_for ?flags ?rflags ?resizable ?show ?x ?y ~w ~h title in
  let b = Bin.scrollbox ?hpolicy ?vpolicy ~pack:win#set_child () in
  (win, b)

let close_windows () =
  Log.debug (fun m -> m "App.close_windows ()");
  let app = app () in
  let l = IMap.bindings app.windows @ app.menu_windows in
  List.iter (fun (_, w) -> w#close) l

let on_window id f =
  let app = app () in
  match Misc.IMap.find_opt id app.windows with
  | Some w -> f (w, false)
  | None ->
      match List.assoc_opt id app.menu_windows with
      | None -> Log.debug (fun m -> m "No window %d" id)
      | Some w -> f (w, true)

let stop app =
  match app.running with
  | None -> ()
  | Some (_,u) ->
      Lwt.wakeup u ();
      app.running <- None

let on_quit () = stop (app())

let quit () =
  let app = app () in
  close_windows ();
  stop app

let create_menu_window ?on_close ?show ~x ~y ~w ~h () =
  let app = app () in
  let win = Window.window
    ~flags:Sdl.Window.(popup_menu+shown+borderless)
      ?rflags:app.renderer_flags ?show ~x ~y ~w ~h ""
  in
  app.menu_windows <- (win#window_id, win) :: app.menu_windows;
  let on_close_cb () =
    Log.debug (fun m -> m "App.on_close_cb on menu window %s" win#me);
    win#remove_child ;
    app.menu_windows <- List.remove_assoc win#window_id app.menu_windows;
    let last =
      (* we give focus to previous menu window, to make sure that
         a non-menu window does not get the focus, or else all menu
         windows will be destroyed *)
      match app.menu_windows with
      | [] -> true
      | (id,w) :: _ -> ignore(w#grab_focus ()) ; false
    in
    match on_close with
    | None -> ()
    | Some f -> f last
  in
  win#set_on_close on_close_cb ;
  win

let popup_menu ?x ?y ?(on_close:(bool->unit) option) (m:Widget.widget) =
  let (_,(mouse_x,mouse_y)) = Sdl.get_global_mouse_state () in
  let w = m#min_width in
  let h = m#min_height in
  let x =
    match x with
    | Some x  -> x
    | None ->
      let> dm = Sdl.get_desktop_display_mode 0 in
      if mouse_x + w <= dm.dm_w || mouse_x - w < 0 then
        mouse_x
      else
        mouse_x - w
  in
  let y =
    match y with
    | Some y  -> y
    | None ->
        let> dm = Sdl.get_desktop_display_mode 0 in
        if mouse_y + h <= dm.dm_h || mouse_y - h < 0 then
        mouse_y
      else
        mouse_y - h
  in
  let g = { G.x = 0 ; y = 0 ; w ; h } in
  let win = create_menu_window ?on_close ~x ~y ~w:g.w ~h:g.h () in
  win#set_child m;
  let _ = win#grab_focus () in
  win

let close_menu_windows () =
 let app = app () in
  match app.menu_windows with
  | [] -> ()
  | _ ->
      Log.debug (fun m -> m "Closing menu windows");
      List.iter (fun (_,w) -> w#close) app.menu_windows


let render_app app =
  IMap.iter (fun _ w -> w#render_if_needed) app.windows ;
  List.iter (fun (_, w) -> w#render_if_needed) app.menu_windows

let event_handler app e =
  try
    (*Format.fprintf Format.err_formatter "EVENT(@%s): %a"
       (Int32.to_string (Sdl.get_ticks())) Fmts.pp_event e ;*)
    (*Log.info (fun m -> m "event_handler e=%a"
       Fmts.pp_event e );*)

    match Misc.event_typ_and_window_id e with
    | `Quit, _ -> on_quit ()
    | `Window_event, Some wid ->
        on_window wid
          (fun (w, is_menu) ->
             let () =
               match Sdl.Event.(window_event_enum (get e window_event_id)) with
               | `Enter | `Leave | `Focus_lost -> ()
               | _ when not is_menu ->
                   Log.debug (fun m -> m "on event %a, closing menu windows (window#wtree: %a)"
                      Fmts.pp_event e Widget.pp_widget_tree w#wtree);

                   close_menu_windows ()
               | _ -> ()
             in
             w#on_window_event e)
    | _, Some wid ->
        on_window wid
          (fun (w, is_menu) ->
             let () =
               match Sdl.Event.(enum (get e typ)) with
               | `Key_down
               | `Mouse_button_down
               | `Mouse_wheel when not is_menu ->
                   close_menu_windows ()
               | _ -> ()
             in
             let pos = Misc.mouse_event_position w#window e in
             (* if event is mouse motion, we pass the also the
                old position, so that a widget can
                detect mouse leaving a widget, without having
                  to go down all the widget hierarchy for each
                mouse motion event. *)
             let oldpos =
               match pos with
               | None -> None
               | Some (x,y) ->
                   match Sdl.Event.(enum (get e typ)) with
                   | `Mouse_motion ->
                       let dx = Sdl.Event.(get e mouse_motion_xrel) in
                       let dy = Sdl.Event.(get e mouse_motion_yrel) in
                       Some (x - dx, y - dy)
                   | _ -> None
             in
             Log.debug
               (fun m -> m "sending event, oldpos=%s, pos=%s"
                  (match oldpos with None -> "None" | Some (x,y) -> Printf.sprintf "%d,%d" x y)
                    (match pos with None -> "None" | Some (x,y) -> Printf.sprintf "%d,%d" x y)
               );
             let _ = w#on_root_event ~oldpos pos e in
             ()
          );
    | _ -> ()
  with
  | e ->
      Log.err (fun m -> m "%s%s" (Printexc.to_string e) (Printexc.get_backtrace()));
      ()

let check_sdl_events app =
  let e = Sdl.Event.create () in
  let rec loop ?(render=true) () =
    match app.running with
    | None -> Lwt.return_unit
    | Some _ ->
       if render then render_app app;
       match%lwt Lwt_preemptive.detach
          (Sdl.wait_event_timeout (Some e)) app.event_delay
        with
       | false -> loop ()
       | true ->
            event_handler app e;
            let render =
              match Sdl.Event.(enum (get e typ)) with
              | `Mouse_motion -> false
              | _ -> true
            in
            loop ~render ()
  in
  loop ()

let lwt_engine_check_sdl_events app =
  let e = Sdl.Event.create () in
  let rec loop ?(render=true) () =
    match app.running with
    | None -> ()
    | Some _ ->
        if render then render_app app ;
        match Sdl.poll_event (Some e) with
        | false -> ()
        | true ->
            event_handler app e;
            let render =
              match Sdl.Event.(enum (get e typ)) with
              | `Mouse_motion -> false
              | _ -> true
            in loop ~render ()
  in
  fun (_:Lwt_engine.event) -> loop ()

let () = check_sdl_events_cb := lwt_engine_check_sdl_events

let run () =
  let app = app () in
  match app.running with
  | Some (t,_) -> Log.warn (fun m -> m "Stk app already running"); t
  | None ->
      let (t,u) = Lwt.wait () in
      app.running <- Some (t,u);
      (
       match app.sdl_events_mode with
       | `Detached -> Lwt.async (fun () -> check_sdl_events app);
       | `Lwt_engine -> ()
      );
      t