+++ /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