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