(***********************************************************************)

(*                                                                     *)

(*                 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