diff --git a/sw/ground_segment/tmtc/messages.ml b/sw/ground_segment/tmtc/messages.ml index 920afe7423..0661e986aa 100644 --- a/sw/ground_segment/tmtc/messages.ml +++ b/sw/ground_segment/tmtc/messages.ml @@ -28,7 +28,7 @@ open Printf 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 dnd_targets = [ { Gtk.target = "STRING"; flags = []; info = 0} ] @@ -38,7 +38,7 @@ let values_of_field = fun field -> try Array.of_list (Str.split pipe_regexp (Xml.attrib field "values")) with - _ -> [||] + _ -> [||] (** Display one page for a message *) 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 = List.fold_left (fun rest f -> - try - let unit = try "("^Xml.attrib f "unit"^")" with _ -> "" in - let field_name = Xml.attrib f "name" in - let type_ = ExtXml.attrib f "type" in - let name = Printf.sprintf "%s %s %s: " type_ field_name unit in - let h = GPack.hbox ~packing:v#pack () in - let field_label = GButton.button ~label:name ~packing:h#pack () in + try + let unit = try "("^Xml.attrib f "unit"^")" with _ -> "" in + let field_name = Xml.attrib f "name" in + let type_ = ExtXml.attrib f "type" in + let name = Printf.sprintf "%s %s %s: " type_ field_name unit in + let h = GPack.hbox ~packing:v#pack () in + let field_label = GButton.button ~label:name ~packing:h#pack () in - let value = ref "XXXX" in - let l = GMisc.label ~text: !value ~packing:h#pack () in - let literal_values = values_of_field f in - let alt_value = - try - let coeff = float_of_string (Pprz.alt_unit_coef_of_xml f) - and unit = Xml.attrib f "alt_unit" in - fun value -> sprintf "%s (%f%s)" value (coeff*.float_of_string value) unit - with - _ -> fun value -> value in - let update = fun (_a, x) -> - value := - try - let i = Pprz.int_of_value x in - sprintf "%s (%d)" literal_values.(i) i - with _ -> - alt_value (Pprz.string_of_value x) - and display_value = fun () -> - if notebook#page_num v#coerce = notebook#current_page then - if l#label <> !value then l#set_text !value in + let value = ref "XXXX" in + let l = GMisc.label ~text: !value ~packing:h#pack () in + let literal_values = values_of_field f in + let alt_value = + try + let coeff = float_of_string (Pprz.alt_unit_coef_of_xml f) + and unit = Xml.attrib f "alt_unit" in + fun value -> sprintf "%s (%f%s)" value (coeff*.float_of_string value) unit + with + _ -> fun value -> value in + let update = fun (_a, x) -> + value := + try + let i = Pprz.int_of_value x in + sprintf "%s (%d)" literal_values.(i) i + with _ -> + alt_value (Pprz.string_of_value x) + and display_value = fun () -> + if notebook#page_num v#coerce = notebook#current_page then + if l#label <> !value then l#set_text !value in - (* box dragger *) - field_label#drag#source_set dnd_targets ~modi:[`BUTTON1] ~actions:[`COPY]; - let data_get = fun _ (sel:GObj.selection_context) ~info ~time -> - let scale = Pprz.alt_unit_coef_of_xml f in - let field_descr = - if Pprz.is_array_type type_ then - match GToolbox.input_string ~title:"Index of value to drag" ~text:"0" "Index in the array ?" with - None -> field_name - | Some i -> sprintf "%s[%s]" field_name i - else - field_name 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); + (* box dragger *) + field_label#drag#source_set dnd_targets ~modi:[`BUTTON1] ~actions:[`COPY]; + let data_get = fun _ (sel:GObj.selection_context) ~info ~time -> + let scale = Pprz.alt_unit_coef_of_xml f in + let field_descr = + if Pprz.is_array_type type_ then + match GToolbox.input_string ~title:"Index of value to drag" ~text:"0" "Index in the array ?" with + None -> field_name + | Some i -> sprintf "%s[%s]" field_name i + else + field_name 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); - (update, display_value)::rest - with - _ -> - fprintf stderr "Warning: Ignoring '%s'\n%!" (Xml.to_string f); - rest + (update, display_value)::rest + with + _ -> + fprintf stderr "Warning: Ignoring '%s'\n%!" (Xml.to_string f); + rest ) [] (Xml.children m) @@ -128,17 +128,17 @@ let one_page = fun sender class_name (notebook:GPack.notebook) bind m -> shown := true; (** Look for the right position in alphabetic order *) let rec loop = fun i -> - let p = notebook#get_nth_page i in - let t = notebook#get_tab_label p in - match t#misc#get_property "name" with - | `STRING (Some x) -> if x < id then loop (i+1) else i - | _ -> raise Not_found + let p = notebook#get_nth_page i in + let t = notebook#get_tab_label p in + match t#misc#get_property "name" with + | `STRING (Some x) -> if x < id then loop (i+1) else i + | _ -> raise Not_found in try - let pos = loop 0 in - ignore (notebook#insert_page ~pos ~tab_label:h#coerce v#coerce) + let pos = loop 0 in + ignore (notebook#insert_page ~pos ~tab_label:h#coerce v#coerce) with _ -> - ignore (notebook#append_page ~tab_label:h#coerce v#coerce) + ignore (notebook#append_page ~tab_label:h#coerce v#coerce) end; time_since_last := 0; try @@ -147,9 +147,9 @@ let one_page = fun sender class_name (notebook:GPack.notebook) bind m -> eb#coerce#misc#set_state `SELECTED; ignore (GMain.Timeout.add led_delay (fun () -> eb#coerce#misc#set_state `NORMAL; false)) with - Invalid_argument "List.iter2" -> - Printf.fprintf stderr "%s: expected %d args, got %d\n" id n (List.length values); flush stderr - | exc -> prerr_endline (Printexc.to_string exc) + Invalid_argument "List.iter2" -> + Printf.fprintf stderr "%s: expected %d args, got %d\n" id n (List.length values); flush stderr + | exc -> prerr_endline (Printexc.to_string exc) in 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 senders = Hashtbl.create 5 in match sender with - | Some "*" -> + | Some "*" -> (* Waiting for a new sender in this class *) let get_one = fun sender _vs -> - if not (Hashtbl.mem senders sender) then begin - Hashtbl.add senders sender (); - one_class notebook (ident, xml_class, Some sender) - end in + if not (Hashtbl.mem senders sender) then begin + Hashtbl.add senders sender (); + one_class notebook (ident, xml_class, Some sender) + end in List.iter - (fun m -> ignore (P.message_bind (Xml.attrib m "name") get_one)) - messages - | _ -> + (fun m -> ignore (P.message_bind (Xml.attrib m "name") get_one)) + messages + | _ -> let class_notebook = GPack.notebook ~tab_border:0 ~tab_pos:`LEFT () in let l = match sender with None -> "" | Some s -> ":"^s in let label = GMisc.label ~text:(ident^l) () in ignore (notebook#append_page ~tab_label:label#coerce class_notebook#coerce); let bind, sender_name = match sender with - None -> (fun m cb -> (P.message_bind m cb)), "*" - | Some sender -> (fun m cb -> (P.message_bind ~sender m cb)), sender in + None -> (fun m cb -> (P.message_bind m cb)), "*" + | Some sender -> (fun m cb -> (P.message_bind ~sender m cb)), sender in (** Forall messages in the class *) let messages = list_sort (fun x -> Xml.attrib x "name") messages in @@ -212,14 +212,14 @@ let _ = let xml = Pprz.messages_xml () in let class_of = fun n -> 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 List.map (fun x -> match Str.split (Str.regexp ":") x with - [cl; s] -> (cl, class_of cl, Some s) - | [cl] -> (x, class_of cl, None) - | _ -> failwith (sprintf "Wrong class '%s', class[:sender] expected" x)) + [cl; s] -> (cl, class_of cl, Some s) + | [cl] -> (x, class_of cl, None) + | _ -> failwith (sprintf "Wrong class '%s', class[:sender] expected" x)) !classes in (* Insert the message classes in the notebook *)