Merge pull request #32 from rebortg/T6342

T6342: add parsing of docs element

2 files changed, 61 insertions, 0 deletions

diff --git a/src/reference_tree.ml b/src/reference_tree.ml
index 0efaf56..874991d 100644
--- a/src/reference_tree.ml
+++ b/src/reference_tree.ml
@@ -20,6 +20,18 @@ type completion_help_type =
     | Script of string [@name "script"]
     [@@deriving yojson]
 
+type doc_hints = {
+    text: string;
+    hint_type: string;
+} [@@deriving yojson]
+
+type docs = {
+    headline: string;
+    text: string;
+    usageExample: string;
+    hints: doc_hints list;
+} [@@deriving yojson]
+
 type ref_node_data = {
     node_type: node_type;
     constraints: Value_checker.value_constraint list;
@@ -35,6 +47,7 @@ type ref_node_data = {
     default_value: string option;
     hidden: bool;
     secret: bool;
+    docs: docs;
 } [@@deriving yojson]
 
 type t = ref_node_data Vytree.t [@@deriving yojson]
@@ -58,6 +71,12 @@ let default_data = {
     default_value = None;
     hidden = false;
     secret = false;
+    docs = {
+        headline = "";
+        text = "";
+        usageExample = "";
+        hints = [];
+    };
 }
 
 let default = Vytree.make default_data ""
@@ -155,6 +174,34 @@ let load_constraint_group_from_xml d c =
         | _ -> raise (Bad_interface_definition ("Malformed constraint: " ^ Xml.to_string c))
     in Xml.fold aux d c
 
+let load_docs_hints d c =
+    let aux d c =
+        match c with
+        | Xml.Element ("hints", attrs, [Xml.PCData s]) ->
+            let hint_type = List.assoc "type" attrs in
+            let hint = { text = s; hint_type = hint_type } in
+            let new_docs = { d.docs with hints = hint :: d.docs.hints } in
+            { d with docs = new_docs }
+        | _ -> raise (Bad_interface_definition ("Malformed hint: " ^ Xml.to_string c))
+    in aux d c
+
+let load_docs_from_xml d x =
+    let aux d x =
+        match x with
+        | Xml.Element ("headline", _, [Xml.PCData s]) ->
+            let new_docs = {d.docs with headline = s} in
+            {d with docs = new_docs}
+        | Xml.Element ("text", _, [Xml.PCData s]) ->
+            let new_docs = {d.docs with text = s} in
+            {d with docs = new_docs}
+        | Xml.Element ("hints", _, _) ->
+            load_docs_hints d x
+        | Xml.Element ("usageExample", _, [Xml.PCData s]) ->
+            let new_docs = {d.docs with usageExample = s} in
+            {d with docs = new_docs}
+        | _ -> d  (* Ignore unknown elements instead of raising an error *)
+    in Xml.fold aux d x
+
 let data_from_xml d x =
     let aux d x =
         match x with
@@ -172,6 +219,7 @@ let data_from_xml d x =
             {d with priority=Some i}
         | Xml.Element ("hidden", _, _) -> {d with hidden=true}
         | Xml.Element ("secret", _, _) -> {d with secret=true}
+        | Xml.Element ("docs", _, _) -> load_docs_from_xml d x
         | _ -> raise (Bad_interface_definition ("Malformed property tag: " ^ Xml.to_string x))
     in Xml.fold aux d x
 
diff --git a/src/reference_tree.mli b/src/reference_tree.mli
index a8d4efa..b1447df 100644
--- a/src/reference_tree.mli
+++ b/src/reference_tree.mli
@@ -9,6 +9,18 @@ type completion_help_type =
     | Script of string [@name "script"]
     [@@deriving yojson]
 
+type doc_hints = {
+    text: string;
+    hint_type: string;
+} [@@deriving yojson]
+
+type docs = {
+    headline: string;
+    text: string;
+    usageExample: string;
+    hints: doc_hints list;
+} [@@deriving to_yojson]
+
 type ref_node_data = {
     node_type: node_type;
     constraints: Value_checker.value_constraint list;
@@ -24,6 +36,7 @@ type ref_node_data = {
     default_value: string option;
     hidden: bool;
     secret: bool;
+    docs: docs;
 } [@@deriving yojson]
 
 type t = ref_node_data Vytree.t [@@deriving yojson]