103 lines
3.7 KiB
OCaml
103 lines
3.7 KiB
OCaml
(***********************************************************************)
|
|
(* *)
|
|
(* MLTk, Tcl/Tk interface of OCaml *)
|
|
(* *)
|
|
(* Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis *)
|
|
(* projet Cristal, INRIA Rocquencourt *)
|
|
(* Jacques Garrigue, Kyoto University RIMS *)
|
|
(* *)
|
|
(* Copyright 2002 Institut National de Recherche en Informatique et *)
|
|
(* en Automatique and Kyoto University. All rights reserved. *)
|
|
(* This file is distributed under the terms of the GNU Library *)
|
|
(* General Public License, with the special exception on linking *)
|
|
(* described in file LICENSE found in the OCaml source tree. *)
|
|
(* *)
|
|
(***********************************************************************)
|
|
|
|
(* $Id$ *)
|
|
|
|
open StdLabels
|
|
|
|
(* easy balloon help facility *)
|
|
|
|
open Tk
|
|
open Widget
|
|
open Protocol
|
|
open Support
|
|
|
|
(* switch -- if you do not want balloons, set false *)
|
|
let flag = ref true
|
|
let debug = ref false
|
|
|
|
(* We assume we have at most one popup label at a time *)
|
|
let topw = ref default_toplevel
|
|
and popupw = ref (Obj.magic dummy : message widget)
|
|
|
|
let configure_cursor w cursor =
|
|
(* DDDDDDDDDIIIIIIIRRRRRRRRTTTTTTTTYYYYYYY *)
|
|
Protocol.tkCommand [| TkToken (name w);
|
|
TkToken "configure";
|
|
TkToken "-cursor";
|
|
TkToken cursor |]
|
|
|
|
let put ~on: w ~ms: millisec mesg =
|
|
let t = ref None in
|
|
let cursor = ref "" in
|
|
|
|
let reset () =
|
|
begin
|
|
match !t with
|
|
Some t -> Timer.remove t
|
|
| _ -> ()
|
|
end;
|
|
(* if there is a popup label, unmap it *)
|
|
if Winfo.exists !topw && Wm.state !topw <> "withdrawn" then
|
|
begin
|
|
Wm.withdraw !topw;
|
|
if Winfo.exists w then configure_cursor w !cursor
|
|
end
|
|
and set ev =
|
|
if !flag then
|
|
t := Some (Timer.add ~ms: millisec ~callback: (fun () ->
|
|
t := None;
|
|
if !debug then
|
|
prerr_endline ("Balloon: " ^ Widget.name w);
|
|
update_idletasks();
|
|
Message.configure !popupw ~text: mesg;
|
|
raise_window !topw;
|
|
Wm.geometry_set !topw (* 9 & 8 are some kind of magic... *)
|
|
("+"^(string_of_int (ev.ev_RootX + 9))^
|
|
"+"^(string_of_int (ev.ev_RootY + 8)));
|
|
Wm.deiconify !topw;
|
|
cursor := cget w `Cursor;
|
|
configure_cursor w "hand2"))
|
|
in
|
|
|
|
List.iter [[`Leave]; [`ButtonPress]; [`ButtonRelease]; [`Destroy];
|
|
[`KeyPress]; [`KeyRelease]]
|
|
~f:(fun events -> bind w ~events ~extend:true ~action:(fun _ -> reset ()));
|
|
List.iter [[`Enter]; [`Motion]] ~f:
|
|
begin fun events ->
|
|
bind w ~events ~extend:true ~fields:[`RootX; `RootY]
|
|
~action:(fun ev -> reset (); set ev)
|
|
end
|
|
|
|
let init () =
|
|
let t = Hashtbl.create 101 in
|
|
Protocol.add_destroy_hook (fun w ->
|
|
Hashtbl.remove t w);
|
|
topw := Toplevel.create default_toplevel;
|
|
Wm.overrideredirect_set !topw true;
|
|
Wm.withdraw !topw;
|
|
popupw := Message.create !topw ~name: "balloon"
|
|
~background: (`Color "yellow") ~aspect: 300;
|
|
pack [!popupw];
|
|
bind_class "all" ~events: [`Enter] ~extend:true ~fields:[`Widget] ~action:
|
|
begin fun w ->
|
|
try Hashtbl.find t w.ev_Widget
|
|
with Not_found ->
|
|
Hashtbl.add t w.ev_Widget ();
|
|
let x = Option.get w.ev_Widget ~name: "balloon" ~clas: "Balloon" in
|
|
if x <> "" then put ~on: w.ev_Widget ~ms: 1000 x
|
|
end
|