Mirrors_Framework/paparazzi
1
0
Fork 0
mirror of https://github.com/paparazzi/paparazzi.git synced 2026-05-31 20:38:27 +08:00
Code Issues Actions 30 Packages Projects Releases Wiki Activity

untabify messages.ml

Browse Source
This commit is contained in:
Felix Ruess
2012-01-10 11:29:47 +01:00
parent 68f2294e5a
commit cae4eb48a4
1 changed files with 72 additions and 72 deletions
Download Patch File Download Diff File Expand all files Collapse all files
sw/ground_segment/tmtc/messages.ml
+72 -72
View File
@@ -28,7 +28,7 @@ open Printf
let list_sort = fun f l -> List.sort (fun x y -> compare (f x) (f y)) l let list_sort = fun f l -> List.sort (fun x y -> compare (f x) (f y)) l
let display_delay = 500 (* Time in second between two updates *) let display_delay = 500 (* Time in milliseconds between two updates *)
let led_delay = 500 (* Time in milliseconds while the green led is displayed *) let led_delay = 500 (* Time in milliseconds while the green led is displayed *)
let dnd_targets = [ { Gtk.target = "STRING"; flags = []; info = 0} ] let dnd_targets = [ { Gtk.target = "STRING"; flags = []; info = 0} ]
@@ -38,7 +38,7 @@ let values_of_field = fun field ->
try try
Array.of_list (Str.split pipe_regexp (Xml.attrib field "values")) Array.of_list (Str.split pipe_regexp (Xml.attrib field "values"))
with with
_ -> [||] _ -> [||]
(** Display one page for a message *) (** Display one page for a message *)
let one_page = fun sender class_name (notebook:GPack.notebook) bind m -> let one_page = fun sender class_name (notebook:GPack.notebook) bind m ->
@@ -54,54 +54,54 @@ let one_page = fun sender class_name (notebook:GPack.notebook) bind m ->
let fields = let fields =
List.fold_left List.fold_left
(fun rest f -> (fun rest f ->
try try
let unit = try "("^Xml.attrib f "unit"^")" with _ -> "" in let unit = try "("^Xml.attrib f "unit"^")" with _ -> "" in
let field_name = Xml.attrib f "name" in let field_name = Xml.attrib f "name" in
let type_ = ExtXml.attrib f "type" in let type_ = ExtXml.attrib f "type" in
let name = Printf.sprintf "%s %s %s: " type_ field_name unit in let name = Printf.sprintf "%s %s %s: " type_ field_name unit in
let h = GPack.hbox ~packing:v#pack () in let h = GPack.hbox ~packing:v#pack () in
let field_label = GButton.button ~label:name ~packing:h#pack () in let field_label = GButton.button ~label:name ~packing:h#pack () in
let value = ref "XXXX" in let value = ref "XXXX" in
let l = GMisc.label ~text: !value ~packing:h#pack () in let l = GMisc.label ~text: !value ~packing:h#pack () in
let literal_values = values_of_field f in let literal_values = values_of_field f in
let alt_value = let alt_value =
try try
let coeff = float_of_string (Pprz.alt_unit_coef_of_xml f) let coeff = float_of_string (Pprz.alt_unit_coef_of_xml f)
and unit = Xml.attrib f "alt_unit" in and unit = Xml.attrib f "alt_unit" in
fun value -> sprintf "%s (%f%s)" value (coeff*.float_of_string value) unit fun value -> sprintf "%s (%f%s)" value (coeff*.float_of_string value) unit
with with
_ -> fun value -> value in _ -> fun value -> value in
let update = fun (_a, x) -> let update = fun (_a, x) ->
value := value :=
try try
let i = Pprz.int_of_value x in let i = Pprz.int_of_value x in
sprintf "%s (%d)" literal_values.(i) i sprintf "%s (%d)" literal_values.(i) i
with _ -> with _ ->
alt_value (Pprz.string_of_value x) alt_value (Pprz.string_of_value x)
and display_value = fun () -> and display_value = fun () ->
if notebook#page_num v#coerce = notebook#current_page then if notebook#page_num v#coerce = notebook#current_page then
if l#label <> !value then l#set_text !value in if l#label <> !value then l#set_text !value in
(* box dragger *) (* box dragger *)
field_label#drag#source_set dnd_targets ~modi:[`BUTTON1] ~actions:[`COPY]; field_label#drag#source_set dnd_targets ~modi:[`BUTTON1] ~actions:[`COPY];
let data_get = fun _ (sel:GObj.selection_context) ~info ~time -> let data_get = fun _ (sel:GObj.selection_context) ~info ~time ->
let scale = Pprz.alt_unit_coef_of_xml f in let scale = Pprz.alt_unit_coef_of_xml f in
let field_descr = let field_descr =
if Pprz.is_array_type type_ then if Pprz.is_array_type type_ then
match GToolbox.input_string ~title:"Index of value to drag" ~text:"0" "Index in the array ?" with match GToolbox.input_string ~title:"Index of value to drag" ~text:"0" "Index in the array ?" with
None -> field_name None -> field_name
| Some i -> sprintf "%s[%s]" field_name i | Some i -> sprintf "%s[%s]" field_name i
else else
field_name in field_name in
sel#return (sprintf "%s:%s:%s:%s:%s" sender class_name id field_descr scale) in sel#return (sprintf "%s:%s:%s:%s:%s" sender class_name id field_descr scale) in
ignore (field_label#drag#connect#data_get ~callback:data_get); ignore (field_label#drag#connect#data_get ~callback:data_get);
(update, display_value)::rest (update, display_value)::rest
with with
_ -> _ ->
fprintf stderr "Warning: Ignoring '%s'\n%!" (Xml.to_string f); fprintf stderr "Warning: Ignoring '%s'\n%!" (Xml.to_string f);
rest rest
) )
[] []
(Xml.children m) (Xml.children m)
@@ -128,17 +128,17 @@ let one_page = fun sender class_name (notebook:GPack.notebook) bind m ->
shown := true; shown := true;
(** Look for the right position in alphabetic order *) (** Look for the right position in alphabetic order *)
let rec loop = fun i -> let rec loop = fun i ->
let p = notebook#get_nth_page i in let p = notebook#get_nth_page i in
let t = notebook#get_tab_label p in let t = notebook#get_tab_label p in
match t#misc#get_property "name" with match t#misc#get_property "name" with
| `STRING (Some x) -> if x < id then loop (i+1) else i | `STRING (Some x) -> if x < id then loop (i+1) else i
| _ -> raise Not_found | _ -> raise Not_found
in in
try try
let pos = loop 0 in let pos = loop 0 in
ignore (notebook#insert_page ~pos ~tab_label:h#coerce v#coerce) ignore (notebook#insert_page ~pos ~tab_label:h#coerce v#coerce)
with _ -> with _ ->
ignore (notebook#append_page ~tab_label:h#coerce v#coerce) ignore (notebook#append_page ~tab_label:h#coerce v#coerce)
end; end;
time_since_last := 0; time_since_last := 0;
try try
@@ -147,9 +147,9 @@ let one_page = fun sender class_name (notebook:GPack.notebook) bind m ->
eb#coerce#misc#set_state `SELECTED; eb#coerce#misc#set_state `SELECTED;
ignore (GMain.Timeout.add led_delay (fun () -> eb#coerce#misc#set_state `NORMAL; false)) ignore (GMain.Timeout.add led_delay (fun () -> eb#coerce#misc#set_state `NORMAL; false))
with with
Invalid_argument "List.iter2" -> Invalid_argument "List.iter2" ->
Printf.fprintf stderr "%s: expected %d args, got %d\n" id n (List.length values); flush stderr Printf.fprintf stderr "%s: expected %d args, got %d\n" id n (List.length values); flush stderr
| exc -> prerr_endline (Printexc.to_string exc) | exc -> prerr_endline (Printexc.to_string exc)
in in
bind id display bind id display
@@ -159,24 +159,24 @@ let rec one_class = fun (notebook:GPack.notebook) (ident, xml_class, sender) ->
let module P = Pprz.Messages (struct let name = class_name end) in let module P = Pprz.Messages (struct let name = class_name end) in
let senders = Hashtbl.create 5 in let senders = Hashtbl.create 5 in
match sender with match sender with
| Some "*" -> | Some "*" ->
(* Waiting for a new sender in this class *) (* Waiting for a new sender in this class *)
let get_one = fun sender _vs -> let get_one = fun sender _vs ->
if not (Hashtbl.mem senders sender) then begin if not (Hashtbl.mem senders sender) then begin
Hashtbl.add senders sender (); Hashtbl.add senders sender ();
one_class notebook (ident, xml_class, Some sender) one_class notebook (ident, xml_class, Some sender)
end in end in
List.iter List.iter
(fun m -> ignore (P.message_bind (Xml.attrib m "name") get_one)) (fun m -> ignore (P.message_bind (Xml.attrib m "name") get_one))
messages messages
| _ -> | _ ->
let class_notebook = GPack.notebook ~tab_border:0 ~tab_pos:`LEFT () in let class_notebook = GPack.notebook ~tab_border:0 ~tab_pos:`LEFT () in
let l = match sender with None -> "" | Some s -> ":"^s in let l = match sender with None -> "" | Some s -> ":"^s in
let label = GMisc.label ~text:(ident^l) () in let label = GMisc.label ~text:(ident^l) () in
ignore (notebook#append_page ~tab_label:label#coerce class_notebook#coerce); ignore (notebook#append_page ~tab_label:label#coerce class_notebook#coerce);
let bind, sender_name = match sender with let bind, sender_name = match sender with
None -> (fun m cb -> (P.message_bind m cb)), "*" None -> (fun m cb -> (P.message_bind m cb)), "*"
| Some sender -> (fun m cb -> (P.message_bind ~sender m cb)), sender in | Some sender -> (fun m cb -> (P.message_bind ~sender m cb)), sender in
(** Forall messages in the class *) (** Forall messages in the class *)
let messages = list_sort (fun x -> Xml.attrib x "name") messages in let messages = list_sort (fun x -> Xml.attrib x "name") messages in
@@ -212,14 +212,14 @@ let _ =
let xml = Pprz.messages_xml () in let xml = Pprz.messages_xml () in
let class_of = fun n -> let class_of = fun n ->
try try
List.find (fun x -> ExtXml.attrib x "name" = n) (Xml.children xml) List.find (fun x -> ExtXml.attrib x "name" = n) (Xml.children xml)
with Not_found -> failwith (sprintf "Unknown messages class: %s" n) in with Not_found -> failwith (sprintf "Unknown messages class: %s" n) in
List.map (fun x -> List.map (fun x ->
match Str.split (Str.regexp ":") x with match Str.split (Str.regexp ":") x with
[cl; s] -> (cl, class_of cl, Some s) [cl; s] -> (cl, class_of cl, Some s)
| [cl] -> (x, class_of cl, None) | [cl] -> (x, class_of cl, None)
| _ -> failwith (sprintf "Wrong class '%s', class[:sender] expected" x)) | _ -> failwith (sprintf "Wrong class '%s', class[:sender] expected" x))
!classes in !classes in
(* Insert the message classes in the notebook *) (* Insert the message classes in the notebook *)