--- /dev/null
+(* $Id$ *)
+
+open GObj
+
+open Common
+
+external test_modifier : Gdk.Tags.modifier -> int -> bool
+ = "ml_test_GdkModifier_val"
+
+
+(************* types *************)
+(* used in the load_parser and for the selection *)
+
+(* widget: class * name * property list
+ where property = name * value_string *)
+type yywidget = string * string * (string * string) list
+type yywidget_tree = Node of yywidget * yywidget_tree list
+
+
+(*********** some utility functions **************)
+let rec list_remove ~f = function
+ | [] -> []
+ | hd :: tl -> if f hd then tl else hd :: (list_remove ~f tl)
+
+
+(* cut the list at the element elt; elt stays in tail;
+ hd stays in reverse order *)
+let cut_list ~item l =
+ let rec aux h t = match t with
+ | hd :: tl -> if hd = item then h, t
+ else aux (hd :: h) tl
+ | [] -> failwith "cut_list"
+ in aux [] l
+
+let list_pos ~item l =
+ let rec aux pos = function
+ | [] -> raise Not_found
+ | hd :: tl -> if hd = item then pos else aux (pos+1) tl
+ in aux 0 l
+
+(* moves the pos element up; pos is >= 1;
+ the first element is numbered 0 *)
+let rec list_reorder_up ~pos = function
+ | hd1 :: hd2 :: tl when pos = 1 -> hd2 :: hd1 :: tl
+ | hd :: tl when pos > 1 -> hd :: (list_reorder_up ~pos:(pos-1) tl)
+ | _ -> failwith "list_reorder"
+
+(* moves the pos element down; pos is < length of l - 1;
+ the first element is numbered 0 *)
+let rec list_reorder_down ~pos =
+ list_reorder_up ~pos:(pos+1)
+
+
+let rec list_insert ~item l ~pos =
+ if pos=0 then item :: l
+ else
+ match l with
+ | [] -> failwith "list_insert"
+ | hd :: tl -> hd :: (list_insert ~item tl ~pos:(pos-1))
+
+
+let rec change_property_name oldname newname = function
+ | (n, p) :: tl when oldname = n -> (newname, p) :: tl
+ | (n, p) :: tl -> (n, p) :: change_property_name oldname newname tl
+ | [] -> failwith "change_property_name: name not found"
+
+
+
+(* contains the list of names of widgets in the current project;
+ used to test if a name is already used;
+ a name is added to the list when a tiwrapper is created (in
+ the initilizer part of tiwrapper,
+ it is removed when the widget is removed from his parent,
+ in method remove_me of tiwrapper *)
+let name_list = ref ([] : string list)
+
+let split name =
+ let l = String.length name in
+ let i = ref (l-1) in
+ while !i >= 0 && name.[!i] >= '0' && name.[!i] <= '9' do decr i done;
+ if !i = l-1 then
+ name, (-1)
+ else
+ (String.sub name ~pos:0 ~len:(!i+1)),
+ int_of_string (String.sub name ~pos:(!i+1) ~len:(l- !i-1))
+
+let test_unique name = not (List.mem name !name_list)
+
+let make_new_name ?(index=1) base =
+ let index, name =
+ if index = -1 then ref 1, ref base
+ else ref index, ref (base ^ (string_of_int index)) in
+ while not (test_unique !name) do
+ incr index;
+ name := base ^ (string_of_int !index)
+ done;
+ !name
+
+let change_name name =
+ let base, index = split name in make_new_name base ~index
+
+let message s =
+ let w = GWindow.window ~show:true ~modal:true () in
+ let v = GPack.vbox ~packing:w#add () in
+ let l = GMisc.label ~text:s ~packing:v#add () in
+ let b = GButton. button ~label:"OK" ~packing:v#add () in
+ b#connect#clicked ~callback:w#destroy;
+ w#connect#destroy ~callback:GMain.Main.quit;
+ GMain.Main.main ()
+
+let message_name () = message "name already in use\npick a new name"
+
+(* better: use a spin button *)
+let get_a_number s default=
+ let res = ref default in
+ let w = GWindow.window ~show:true ~modal:true () in
+ let v = GPack.vbox ~packing:w#add () in
+ let l = GMisc.label ~text:s ~packing:v#add () in
+ let e = GEdit.entry ~text:(string_of_int default) ~packing:v#add () in
+ let b = GButton. button ~label:"OK" ~packing:v#add () in
+ b#connect#clicked ~callback:(fun () ->
+ begin try res := int_of_string e#text with Failure _ -> () end;
+ w#destroy ());
+ w#connect#destroy ~callback:GMain.Main.quit;
+ GMain.Main.main ();
+ !res
+
+
+(*************** file selection *****************)
+
+let get_filename ~callback:set_filename ?(dir="") () =
+ let res = ref false in
+ let file_selection = GWindow.file_selection ~modal:true () in
+ if dir <> "" then file_selection#set_filename dir;
+ file_selection#show ();
+ file_selection#ok_button#connect#clicked
+ ~callback:(fun () -> set_filename file_selection#get_filename;
+ res := true;
+ file_selection#destroy ());
+ file_selection#cancel_button#connect#clicked
+ ~callback:file_selection#destroy;
+ file_selection#connect#destroy ~callback:GMain.Main.quit;
+ GMain.Main.main ();
+ !res
+
+(* returns the directory and the file name (without the extension) *)
+let split_filename filename ~ext =
+ let lext = String.length ext in
+ let l = String.length filename in
+ let filename, l =
+ if (l > lext) && (String.sub filename ~pos:(l - lext) ~len:lext = ext)
+ then (String.sub filename ~pos:0 ~len:(l-lext)), l-lext
+ else filename, l in
+ let i = 1 + (String.rindex filename '/') in
+ String.sub filename ~pos:0 ~len:i,
+ String.sub filename ~pos:i ~len:(l-i)
+
+
+(****************** ML signals *****************)
+let signal_id = ref 0
+
+let next_callback_id () : GtkSignal.id =
+ decr signal_id; Obj.magic (!signal_id : int)
+
+class ['a] signal = object
+ val mutable callbacks : (GtkSignal.id * ('a -> unit)) list = []
+ method connect ~callback ~after =
+ let id = next_callback_id () in
+ callbacks <-
+ if after then callbacks @ [id,callback] else (id,callback)::callbacks;
+ id
+ method call arg =
+ List.iter callbacks ~f:(fun (_,f) -> f arg)
+ method disconnect id =
+ List.mem_assoc id callbacks &&
+ (callbacks <- List.remove_assoc id callbacks; true)
+ method reset () = callbacks <- []
+end
+
+class type disconnector =
+ object
+ method disconnect : GtkSignal.id -> bool
+ method reset : unit -> unit
+ end
+
+class has_ml_signals = object
+ val mutable disconnectors = []
+ method private add_signal (sgn : 'a signal) =
+ disconnectors <- (sgn :> disconnector) :: disconnectors
+
+ method disconnect id =
+ List.exists disconnectors ~f:(fun d -> d#disconnect id)
+end
+
+
+(****************** undo information ********************)
+
+type undo_action =
+ | Add of string * yywidget_tree * int
+ | Remove of string
+ | Property of prop * string
+ | Add_window of yywidget_tree
+ | Remove_window of string
+
+let undo_info = ref ([] : undo_action list)
+let next_undo_info = ref ([] : undo_action list)
+let last_action_was_undo = ref false
+
+let add_undo f =
+ undo_info := f :: !undo_info;
+ last_action_was_undo := false
+
+
+(**********************************************************)
+let ftrue f = fun x -> f x; true
+
+
+(**********************************************************)
+
+let toolbar_child_prop kind =
+ let rt = ref "" and rtt = ref "" and rptt = ref "" and ok = ref false in
+ let w = GWindow.window ~modal:true () in
+ let v = GPack.vbox ~packing:w#add () in
+ let h1 = GPack.hbox ~packing:v#pack () in
+ let h2 = GPack.hbox ~packing:v#pack () in
+ let h3 = GPack.hbox ~packing:v#pack () in
+ let h4 = GPack.hbox ~packing:v#pack () in
+ let l1 = GMisc.label ~text:"text" ~packing:h1#pack () in
+ let e1 = GEdit.entry ~packing:h1#pack () in
+ let l2 = GMisc.label ~text:"tooltip_text" ~packing:h2#pack () in
+ let e2 = GEdit.entry ~packing:h2#pack () in
+ let l3 = GMisc.label ~text:"private_text" ~packing:h3#pack () in
+ let e3 = GEdit.entry ~packing:h3#pack () in
+ let b1 = GButton.button ~label:"OK" ~packing:h4#pack () in
+ let b2 = GButton.button ~label:"Cancel" ~packing:h4#pack () in
+ w#show ();
+ b1#connect#clicked
+ ~callback:(fun () -> rt := e1#text; rtt := e2#text;
+ rptt := e3#text; ok := true;
+ w#destroy ());
+ b2#connect#clicked ~callback:w#destroy;
+ w#connect#destroy ~callback:GMain.Main.quit;
+ GMain.Main.main ();
+ !ok, !rt, !rtt, !rptt
+
+
+
+(**********************************************************)
+
+let get5floats_from_string s =
+ try
+ let n1 = String.index s ' ' in
+ let f1 = float_of_string (String.sub s ~pos:0 ~len:(n1-1)) in
+ let n2 = String.index_from s (n1+1) ' ' in
+ let f2 = float_of_string (String.sub s ~pos:(n1+1) ~len:(n2-1)) in
+ let n3 = String.index_from s (n2+1) ' ' in
+ let f3 = float_of_string (String.sub s ~pos:(n2+1) ~len:(n3-1)) in
+ let n4 = String.index_from s (n3+1) ' ' in
+ let f4 = float_of_string (String.sub s ~pos:(n3+1) ~len:(n4-1)) in
+ let f5 = float_of_string (String.sub s ~pos:(n4+1) ~len:
+ ((String.length s) -1)) in
+ f1, f2, f3, f4, f5
+ with _ -> failwith "get5floats_of_string"
+
+
+
+(**********************************************************)
+
+exception Float_of_string
+let my_float_of_string s =
+ let l = String.length s in
+ if l=0 then raise Float_of_string;
+ let sign, d = match s.[0] with
+ | '+' -> 1, 1
+ | '-' -> -1, 1
+ | _ -> 1, 0 in
+ let m, p =
+ let p =
+ try
+ String.index s '.'
+ with Not_found -> l in
+ if p=d then 0, p
+ else
+ try int_of_string (String.sub s ~pos:d ~len:(p-d)), p
+ with Failure "int_of_string" -> raise Float_of_string
+ in
+ if p=l then float_of_int m
+ else begin
+ let f = ref 0. and r = ref 0.1 in
+ for i = p+1 to l-1 do
+ let k = (int_of_char s.[i]) - 48 in
+ if k > 9 || k < 0 then raise Float_of_string;
+ f := !f +. (float_of_int k) *. !r;
+ r := !r *. 0.1
+ done;
+ !f +. (float_of_int m)
+ end
+
+
+
+
+class entry_float obj ~init = let rv = ref init in
+object
+ inherit GEdit.entry obj as entry
+ method value =
+ try
+ let v = my_float_of_string entry#text in
+ rv := v;
+ v
+ with Float_of_string ->
+ let pop = GWindow.window ~title:"error" ~modal:true () in
+ let vb = GPack.vbox ~packing:pop#add () in
+ let l = GMisc.label ~text:"value must be a float" ~packing:vb#pack () in
+ let b = GButton.button ~label:"OK" ~packing:vb#pack () in
+ b#connect#clicked ~callback:pop#destroy;
+ pop#event#connect#delete ~callback:(fun _ -> pop#destroy (); true);
+ pop#connect#destroy ~callback:GtkMain.Main.quit;
+ pop#show ();
+ GtkMain.Main.main ();
+ entry#set_text (string_of_float !rv);
+ !rv
+end
+
+
+let set_editable ?editable ?(width = -2) ?(height = -2) w =
+ Gaux.may editable ~f:(GtkEdit.Editable.set_editable w);
+ if width <> -2 || height <> -2 then GtkBase.Widget.set_usize w ~width ~height
+
+
+let entry_float ~init ?max_length ?visibility ?editable
+ ?width ?height ?packing ?show () =
+ let w = GtkEdit.Entry.create ?max_length () in
+ GtkEdit.Entry.set w ~text:(string_of_float init) ?visibility;
+ set_editable w ?editable ?width ?height;
+ pack_return (new entry_float w ~init) ~packing ~show
+
+
+(*************************************************************)
+
+
+let split_string s ~sep =
+ let l = String.length s in
+ let r = ref [] in
+ let j = ref 0 in
+ for i = 0 to l-1 do
+ if String.unsafe_get s i = sep then begin
+ r := (String.sub s ~pos:!j ~len:(i - !j)) :: !r;
+ j := i + 1
+ end
+ done;
+ List.rev ((String.sub s ~pos:!j ~len:(l - !j)) :: !r)
+
+
projects / helm.git / blobdiff