l4/pkg/ocaml/ocaml/contrib/otherlibs/labltk/frx/frx_dialog.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 open Camltk
  17 open Protocol
  18
  19 let rec mapi f n l =
  20   match l with
  21     [] -> []
  22   | x::l -> let v = f n x in v::(mapi f (succ n) l)
  23
  24 (* Same as tk_dialog, but not sharing the tkwait variable *)
  25 (* w IS the parent widget *)
  26 let f w name title mesg bitmap def buttons =
  27   let t = Toplevel.create_named w name [Class "Dialog"] in
  28     Wm.title_set t title;
  29     Wm.iconname_set t "Dialog";
  30     Wm.protocol_set t "WM_DELETE_WINDOW" (function () -> ());
  31     (* Wm.transient_set t (Winfo.toplevel w); *)
  32   let ftop =
  33    Frame.create_named t "top" [Relief Raised; BorderWidth (Pixels 1)]
  34   and fbot =
  35    Frame.create_named t "bot" [Relief Raised; BorderWidth (Pixels 1)]
  36    in
  37      pack [ftop][Side Side_Top; Fill Fill_Both];
  38      pack [fbot][Side Side_Bottom; Fill Fill_Both];
  39
  40   let l =
  41    Label.create_named ftop "msg"
  42      [Justify Justify_Left; Text mesg; WrapLength (Pixels 600)] in
  43      pack [l][Side Side_Right; Expand true; Fill Fill_Both;
  44               PadX (Millimeters 3.0); PadY (Millimeters 3.0)];
  45   begin match bitmap with
  46      Predefined "" -> ()
  47   |  _ ->
  48     let b =
  49       Label.create_named ftop "bitmap" [Bitmap bitmap] in
  50      pack [b][Side Side_Left; PadX (Millimeters 3.0); PadY (Millimeters 3.0)]
  51   end;
  52
  53   let waitv = Textvariable.create_temporary t in
  54
  55   let buttons =
  56     mapi (fun i bname ->
  57      let b = Button.create t
  58               [Text bname;
  59                Command (fun () -> Textvariable.set waitv (string_of_int i))] in
  60     if i = def then begin
  61       let f = Frame.create_named fbot "default"
  62                  [Relief Sunken; BorderWidth (Pixels 1)] in
  63         raise_window_above b f;
  64         pack [f][Side Side_Left; Expand true;
  65                  PadX (Millimeters 3.0); PadY (Millimeters 2.0)];
  66         pack [b][In f; PadX (Millimeters 2.0); PadY (Millimeters 2.0)];
  67         bind t [[], KeyPressDetail "Return"]
  68          (BindSet ([], (fun _ -> Button.flash b; Button.invoke b)))
  69         end
  70     else
  71       pack [b][In fbot; Side Side_Left; Expand true;
  72                PadX (Millimeters 3.0); PadY (Millimeters 2.0)];
  73     b
  74     )
  75     0 buttons in
  76
  77    Wm.withdraw t;
  78    update_idletasks();
  79    let x = (Winfo.screenwidth t)/2 - (Winfo.reqwidth t)/2 -
  80              (Winfo.vrootx (Winfo.parent t))
  81    and y = (Winfo.screenheight t)/2 - (Winfo.reqheight t)/2 -
  82              (Winfo.vrooty (Winfo.parent t)) in
  83    Wm.geometry_set t (Printf.sprintf "+%d+%d" x y);
  84    Wm.deiconify t;
  85
  86    let oldfocus = try Some (Focus.get()) with _ -> None
  87    and oldgrab = Grab.current ~displayof: t ()
  88    and grabstatus = ref None in
  89     begin match oldgrab with
  90       [] -> ()
  91     | x::l -> grabstatus := Some(Grab.status x)
  92     end;
  93
  94    (* avoid errors here because it makes the entire app useless *)
  95    (try Grab.set t with TkError _ -> ());
  96    Tkwait.visibility t;
  97    Focus.set (if def >= 0 then List.nth buttons def else t);
  98
  99    Tkwait.variable waitv;
 100    begin match oldfocus with
 101        None -> ()
 102      | Some w -> try Focus.set w with _ -> ()
 103    end;
 104    destroy t;
 105    begin match oldgrab with
 106      [] -> ()
 107    | x::l ->
 108       try
 109         match !grabstatus with
 110           Some(GrabGlobal) -> Grab.set_global x
 111         | _ -> Grab.set x
 112       with TkError _ -> ()
 113    end;
 114
 115    int_of_string (Textvariable.get waitv)