T5194: allow for empty element string and child order in valueHelp

One needs to handle the pathological cases of an empty element string
and arbitrary order of child elements. Neither are prohibited, and the
former has a use case (for now).

1 files changed, 34 insertions, 17 deletions

diff --git a/src/reference_tree.ml b/src/reference_tree.ml
index 7b4c85c..e6738aa 100644
--- a/src/reference_tree.ml
+++ b/src/reference_tree.ml
@@ -57,6 +57,39 @@ let node_type_of_string s =
     | _ -> raise (Bad_interface_definition
                   (Printf.sprintf "node, tagNode, or leafNode expected, %s found" s))
 
+(** Find a child node in xml-lite *)
+let find_xml_child name xml =
+    let find_aux e =
+        match e with
+        | Xml.Element (name', _, _) when name' = name -> true
+        | _ -> false
+    in
+    match xml with
+    | Xml.Element (_, _, children) -> Vylist.find find_aux children
+    | Xml.PCData _ -> None
+
+(* handle possible empty elements *)
+let try_pcdata x =
+    match x with
+    | [] -> ""
+    | _ ->
+    try
+        Xml.pcdata (List.hd x)
+    with Xml.Not_pcdata _ -> ""
+
+let get_pcdata_child name xml =
+    let c = find_xml_child name xml in
+    match c with
+    | Some Xml.Element(_, _, x_data) -> try_pcdata x_data
+    | _ -> raise (Bad_interface_definition (Printf.sprintf "No child named %s" name))
+
+let load_value_help_from_xml d x =
+    let fmt = get_pcdata_child "format" x in
+    let descr = get_pcdata_child "description" x in
+    let vhs = d.value_help in
+    let vhs' = (fmt, descr) :: vhs in
+    {d with value_help=vhs'}
+
 let load_constraint_from_xml d c =
     let aux d c =
         match c with
@@ -72,27 +105,11 @@ let load_constraint_from_xml d c =
         | _ -> raise (Bad_interface_definition "Malformed constraint")
     in Xml.fold aux d c
 
-(** Find a child node in xml-lite *)
-let find_xml_child name xml =
-    let find_aux e =
-        match e with
-        | Xml.Element (name', _, _) when name' = name -> true
-        | _ -> false
-    in
-    match xml with
-    | Xml.Element (_, _, children) -> Vylist.find find_aux children
-    | Xml.PCData _ -> None
-
 let data_from_xml d x =
     let aux d x =
         match x with
         | Xml.Element ("help", _, [Xml.PCData s]) -> {d with help=s}
-        | Xml.Element ("valueHelp", _,
-                       [Xml.Element ("format", _, [Xml.PCData fmt]);
-                        Xml.Element ("description", _, [Xml.PCData descr])]) ->
-            let vhs = d.value_help in
-            let vhs' = (fmt, descr) :: vhs in
-            {d with value_help=vhs'}
+        | Xml.Element ("valueHelp", _, _) -> load_value_help_from_xml d x
         | Xml.Element ("multi", _, _) -> {d with multi=true}
         | Xml.Element ("valueless", _, _) -> {d with valueless=true}
         | Xml.Element ("constraintErrorMessage", _, [Xml.PCData s]) ->