l4/pkg/ocaml/ocaml/contrib/otherlibs/labltk/frx/frx_synth.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                 MLTk, Tcl/Tk interface of Objective Caml            *)
   4 (*                                                                     *)
   5 (*    Francois Rouaix, Francois Pessaux, Jun Furuse and Pierre Weis    *)
   6 (*               projet Cristal, INRIA Rocquencourt                    *)
   7 (*            Jacques Garrigue, Kyoto University RIMS                  *)
   8 (*                                                                     *)
   9 (*  Copyright 2002 Institut National de Recherche en Informatique et   *)
  10 (*  en Automatique and Kyoto University.  All rights reserved.         *)
  11 (*  This file is distributed under the terms of the GNU Library        *)
  12 (*  General Public License, with the special exception on linking      *)
  13 (*  described in file LICENSE found in the Objective Caml source tree. *)
  14 (*                                                                     *)
  15 (***********************************************************************)
  16 (* Some notion of synthetic events *)
  17 open Camltk
  18 open Widget
  19 open Protocol
  20
  21 (* To each event is associated a table of (widget, callback) *)
  22 let events = Hashtbl.create 37
  23
  24 (* Notes:
  25  *   "cascading" events (on the same event) are not supported
  26  *   Only one binding active at a time for each event on each widget.
  27  *)
  28
  29 (* Get the callback table associated with <name>. Initializes if required *)
  30 let get_event name =
  31   try Hashtbl.find events name
  32   with
  33     Not_found ->
  34       let h = Hashtbl.create 37 in
  35        Hashtbl.add events name h;
  36        (* Initialize the callback invocation mechanism, based on
  37           variable trace
  38         *)
  39        let var = "camltk_events(" ^ name ^")" in
  40        let tkvar = Textvariable.coerce var in
  41        let rec set () =
  42          Textvariable.handle tkvar
  43          (fun () ->
  44             begin match Textvariable.get tkvar with
  45               "all" -> (* Invoke all callbacks *)
  46                 Hashtbl.iter
  47                   (fun p f ->
  48                      try
  49                       f (cTKtoCAMLwidget p)
  50                      with _ -> ())
  51                   h
  52             | p -> (* Invoke callback for p *)
  53                 try
  54                   let w = cTKtoCAMLwidget p
  55                   and f = Hashtbl.find h p in
  56                     f w
  57                 with
  58                   _ -> ()
  59             end;
  60             set ()(* reactivate the callback *)
  61             ) in
  62        set();
  63        h
  64
  65 (* Remove binding for event <name> on widget <w> *)
  66 let remove w name =
  67   Hashtbl.remove (get_event name) (Widget.name w)
  68
  69 (* Adds <f> as callback for widget <w> on event <name> *)
  70 let bind w name f =
  71   remove w name;
  72   Hashtbl.add (get_event name) (Widget.name w) f
  73
  74 (* Sends event <name> to all widgets *)
  75 let broadcast name =
  76   Textvariable.set (Textvariable.coerce ("camltk_events(" ^ name ^")")) "all"
  77
  78 (* Sends event <name> to widget <w> *)
  79 let send name w =
  80   Textvariable.set (Textvariable.coerce ("camltk_events(" ^ name ^")"))
  81                    (Widget.name w)
  82
  83 (* Remove all callbacks associated to widget <w> *)
  84 let remove_callbacks w =
  85   Hashtbl.iter (fun _ h -> Hashtbl.remove h (Widget.name w)) events
  86
  87 let _ =
  88   add_destroy_hook remove_callbacks