Source file wkey.ml

open Tsdl

type handler =
  { cond : (unit -> bool) ;
    cback : (unit -> unit) ;
  }

module H =
  struct
    type t = Key.keystate * handler

    let filter_with_mask (t:Key.keystate) l =
      List.filter
        (fun a -> not (Key.keystate_equal (fst a) t)) l

    let find_handlers ~kmod ~key l =
      List.map snd
        (List.filter
         (fun (t,_) -> Key.match_keys t ~key ~kmod)
           l
        )

  end

let (table : (Oid.t, H.t list ref) Hashtbl.t) = Hashtbl.create 13

let key_press (w:Widget.widget) (ev:Widget.key_ev) =
  let key = ev.key in
  let modifiers = ev.mods in
  try
    let (r : H.t list ref) = Hashtbl.find table w#id in
    let l = H.find_handlers ~kmod:modifiers ~key !r in
    match l with
    | [] -> false
    | _ ->
        List.iter
          (fun h ->
             if h.cond () then
               try h.cback ()
               with e ->
                 Log.err (fun m -> m "%s" (Printexc.to_string e))
             else ()
          )
          l;
        true
  with
    Not_found -> false

let associate_key_press (w:Widget.widget) =
  let _ = w#connect Widget.Key_pressed (key_press w) in
  ()

let remove_widget (w : Widget.widget) () =
  try
    let r = Hashtbl.find table w#id in
    r := []
  with
    Not_found ->
      ()

let add1 ?(remove=false) (w:Widget.widget)
  ?(cond=(fun () -> true)) ks callback =
  Log.debug (fun m -> m "Wkey.add1 w=%s ks=%a" w#me Key.pp_keystate ks);
  let r =
    try Hashtbl.find table w#id
    with Not_found ->
        let r = ref [] in
        Hashtbl.add table w#id r;
        let _ = w#connect Widget.Destroy
          (fun () -> remove_widget w (); false)
        in
        associate_key_press w;
        r
  in
  let new_h = { cond = cond ; cback = callback } in
  if remove then
    (
     let l = H.filter_with_mask ks !r in
     r := (ks, new_h) :: l
    )
  else
    r := (ks, new_h) :: !r


let add w ?(cond=(fun () -> true)) ks callback =
    add1 w ~cond ks callback

let add_list w ?(cond=(fun () -> true)) ks_list callback =
    List.iter (fun ks -> add w ~cond ks callback) ks_list

let set w ?(cond=(fun () -> true)) ks callback =
    add1 ~remove: true w ~cond ks callback

let set_list w ?(cond=(fun () -> true)) ks_list callback =
    List.iter (fun ks -> set w ~cond ks callback) ks_list

(** {2 Trees of handlers, a la emacs} *)

let ignored_keys =
  let open Sdl.K in
  ref [
    numlockclear ;
    scrolllock ;
    pause ;
    capslock ;
  ]

type handler_tree_node =
  | Handler of handler
  | Node of handler_tree list
and handler_tree =
  { mutable hst_spec : Key.keystate ;
    mutable hst_v : handler_tree_node ;
  }

let string_of_handler_trees =
  let rec iter b margin t =
    match t.hst_v with
    | Handler _ ->
        Printf.bprintf b "%s%s: <handler>\n"
          margin (Key.string_of_keystate t.hst_spec)
  | Node l ->
        Printf.bprintf b "%s%s:\n"
          margin (Key.string_of_keystate t.hst_spec);
        List.iter (iter b (margin^"  ")) l
  in
  fun l ->
    let b = Buffer.create 256 in
    List.iter (iter b "") l;
    Buffer.contents b

let pp_handler_trees ppf l =
  Format.fprintf ppf "%s"
    (string_of_handler_trees l)

type keyhit_state = (Sdl.keymod * Sdl.keycode) list

  (** associations between a widget object id and its associated key press callback
     and its "key hit state" *)
let (states_table : (Oid.t, Events.callback_id * (Sdl.keymod * Sdl.keycode) list) Hashtbl.t) =
  Hashtbl.create 37

let reset_state w =
  let oid = w#id in
  try
    let (evid,state) = Hashtbl.find states_table oid in
    Hashtbl.replace states_table oid (evid, [])
  with Not_found ->
      ()

let rec trees_of_state trees state =
  match state with
  | [] -> trees
  | (mods,k) :: q ->
      let hst = List.find
        (fun t -> Key.match_keys t.hst_spec ~key:k ~kmod:mods) trees
      in
      match hst.hst_v with
      | Handler _ -> raise Not_found
      | Node l -> trees_of_state l q

let on_key_press ?display_state ks_stop f_trees
  (w:Widget.widget) ev =
    try
      let oid = w#id in
      let key = ev.Widget.key in
      let mods = ev.mods in
      Log.debug (fun m ->
         let ks = Key.keystate ~mods key in
         m "%s: key pressed: %a" w#me Key.pp_keystate ks);
      let (evid,state) = Hashtbl.find states_table oid in
      if List.mem key !ignored_keys then raise Not_found;
      if Key.key_is_mod key then
        true
      else
        (
         (*    prerr_endline (Printf.sprintf "key=%X" key);*)
         let disp_state after_handler st =
           match display_state with
           | None -> ()
           | Some f -> f ~after_handler st
         in
         let set_state ?(after_handler=false) st =
           Hashtbl.replace states_table oid (evid, st);
           disp_state after_handler st
         in
         if Key.match_keys ks_stop ~key ~kmod:mods then
           (
            set_state [] ;
            true
           )
         else
           let trees =
             try trees_of_state (f_trees ()) state
             with Not_found ->
                 set_state [] ;
                 raise Not_found
           in
           match List.find_opt
             (fun t -> Key.match_keys t.hst_spec ~key ~kmod:mods) trees
           with
           | None -> set_state [] ; false
           | Some hst ->
               match hst.hst_v with
               | Node _ ->
                   (* only keep mods and key in state, so that masked
                      modifiers are not displayed *)
                   let mods = hst.hst_spec.mods in
                   let key = hst.hst_spec.key in
                   let new_state = state @ [mods,key] in
                   set_state new_state ;
                   true
               | Handler h ->
                   let () =
                     if h.cond () then
                       try h.cback ()
                       with e ->
                           Log.err (fun m -> m "%s" (Printexc.to_string e))
                     else ()
                   in
                   set_state ~after_handler: true [] ;
                   true
        )
  with Not_found ->
      false

let set_handler_trees ?(stop=Key.keystate ~mods:Sdl.Kmod.ctrl Sdl.K.g) f_trees ?display_state
  (w : Widget.widget) =
  let add () =
    let id = w#connect Widget.Key_pressed
      (on_key_press ?display_state stop f_trees w)
    in
    Hashtbl.add states_table w#id (id, []);
    ()
  in
  try
    let (id, _) = Hashtbl.find states_table w#id in
    w#disconnect id ;
    add ()
  with
  | Not_found -> add ()

let handler ?(cond=(fun () -> true)) callback =
  { cond = cond ; cback = callback }

let handler_tree ks v =
  { hst_spec = ks ;
    hst_v = v ;
  }

let rec trees_of_list l =
  match l with
  | [] -> []
  | ([],_) :: q -> trees_of_list q
  | ([ks],f) :: q ->
      (handler_tree ks (Handler (handler f))) ::
        (trees_of_list q)
  | ((ks::b),_) :: q ->
      let pred = function
        ([],_) -> false
      | ((ks2::_),_) -> Key.keystate_equal ks ks2
      in
      let (same,diff) = List.partition pred l in
      let subs = List.map
        (function
             ((_::q),f) -> (q,f)
         | _ -> assert false
        )
          same
      in
      (handler_tree ks (Node (trees_of_list subs))) ::
        (trees_of_list diff)

let string_of_keyhit_state state =
  String.concat ", "
    (List.map
     (fun (kmod,key) ->
        Printf.sprintf "%s%s"
          (if kmod = Sdl.Kmod.none
           then ""
           else (Key.string_of_mods kmod)^"-")
          (Sdl.get_key_name key))
       state)

let pp_keyhit_state fmt s = Format.fprintf fmt "%s"
  (string_of_keyhit_state s)