T8061: extend node_type to path_type for path characteristics

For an arbitrary path, determine if it has the characterists of a
configuration path, and return the potential node type, solely in terms
of the reference tree. No validation is taking place on values.

1 files changed, 64 insertions, 23 deletions

diff --git a/src/reference_tree.ml b/src/reference_tree.ml
index e3b5019..82604f4 100644
--- a/src/reference_tree.ml
+++ b/src/reference_tree.ml
@@ -1,19 +1,32 @@
-type node_type =
-    | Leaf
-    | Tag
-    | Other
+type node_type = [ `Leaf | `Tag | `Other ]
 
 let node_type_to_yojson = function
-    | Leaf -> `String "leaf"
-    | Tag -> `String "tag"
-    | Other -> `String "other"
+    | `Leaf -> `String "leaf"
+    | `Tag -> `String "tag"
+    | `Other -> `String "other"
 
 let node_type_of_yojson = function
-    | `String "leaf" -> Ok Leaf
-    | `String "tag" -> Ok Tag
-    | `String "other" -> Ok Other
+    | `String "leaf" -> Ok `Leaf
+    | `String "tag" -> Ok `Tag
+    | `String "other" -> Ok `Other
     | json -> Error (Yojson.Safe.to_string json)
 
+type path_type = [ node_type | `Tag_value | `Leaf_value | `Multi | `Invalid ]
+
+let path_type_to_yojson = function
+    | `Tag_value -> `String "tag_value"
+    | `Leaf_value -> `String "leaf_value"
+    | `Multi -> `String "multi"
+    | `Invalid -> `String "invalid"
+    | #node_type as c -> node_type_to_yojson c
+
+let path_type_of_yojson = function
+    | `String "tag_value" -> Ok `Tag_value
+    | `String "leaf_value" -> Ok `Leaf_value
+    | `String "multi" -> Ok `Multi
+    | `String "invalid" -> Ok `Invalid
+    | _ as s -> node_type_of_yojson s
+
 type completion_help_type =
     | List of string [@name "list"]
     | Path of string [@name "path"]
@@ -57,7 +70,7 @@ exception Bad_interface_definition of string
 exception Validation_error of string
 
 let default_data = {
-    node_type = Other;
+    node_type = `Other;
     constraints = [];
     constraint_group = [];
     constraint_error_message = "Invalid value";
@@ -85,9 +98,9 @@ let default = Vytree.make default_data ""
 
 let node_type_of_string s =
     match s with
-    | "node" -> Other
-    | "tagNode" -> Tag
-    | "leafNode" -> Leaf
+    | "node" -> `Other
+    | "tagNode" -> `Tag
+    | "leafNode" -> `Leaf
     | _ -> raise (Bad_interface_definition
                   (Printf.sprintf "node, tagNode, or leafNode expected, %s found" s))
 
@@ -260,7 +273,7 @@ let rec insert_from_xml basepath reftree xml =
                 (Vytree.insert_maybe[@alert "-exn"]) reftree path data
         in
         (match node_type with
-        | Leaf -> new_tree
+        | `Leaf -> new_tree
         | _ ->
             let children = find_xml_child "children" xml in
             (match children with
@@ -325,7 +338,7 @@ let validate_path validators_dir node path =
     let rec aux node path acc =
         let data = Vytree.data_of_node node in
         match data.node_type with
-        | Leaf ->
+        | `Leaf ->
             begin
             match path with
             | [] ->
@@ -352,7 +365,7 @@ let validate_path validators_dir node path =
                 let msg = Printf.sprintf "Path %s is too long" (show_path acc)
                 in raise (Validation_error msg)
             end
-        | Tag ->
+        | `Tag ->
             begin
             match path with
             | p :: p' :: ps ->
@@ -415,7 +428,7 @@ let validate_path validators_dir node path =
                     Printf.sprintf "Configuration path %s requires a value" (show_path acc)
                 in raise (Validation_error msg)
             end
-        | Other ->
+        | `Other ->
             begin
             match path with
             | [] -> ()
@@ -434,14 +447,14 @@ let split_path node path =
     let rec aux node path acc =
         let data = Vytree.data_of_node node in
         match data.node_type with
-        | Leaf ->
+        | `Leaf ->
             begin
             match path with
             | [] -> (List.rev acc, None)
             | [p] -> (List.rev acc, Some p)
             | _ -> (List.rev acc, None)
             end
-        | Tag ->
+        | `Tag ->
             begin
             match path with
             | p :: p' :: ps ->
@@ -452,7 +465,7 @@ let split_path node path =
             | [p] -> (List.rev (p :: acc), None)
             | _ -> (List.rev acc, None)
             end
-        | Other ->
+        | `Other ->
             begin
             match path with
             | [] -> (List.rev acc, None)
@@ -507,7 +520,7 @@ let is_tag reftree path =
      *)
     let data = (Vytree.get_data[@alert "-exn"]) reftree path in
     match data.node_type with
-    | Tag -> true
+    | `Tag -> true
     | _ -> false
 
 let is_leaf reftree path =
@@ -520,7 +533,7 @@ let is_leaf reftree path =
      *)
     let data = (Vytree.get_data[@alert "-exn"]) reftree path in
     match data.node_type with
-    | Leaf -> true
+    | `Leaf -> true
     | _ -> false
 
 let is_valueless reftree path =
@@ -696,6 +709,34 @@ let reference_path_exists rtree cpath =
     if Util.is_empty rpath then false
     else true
 
+let get_path_type rtree cpath =
+    if Util.is_empty cpath then `Other
+    else
+    if potential_leaf_value rtree cpath then `Leaf_value
+    else
+    if potential_tag_value rtree cpath then `Tag_value
+    else
+    let rpath = refpath rtree cpath in
+    if Util.is_empty rpath then `Invalid
+    else
+    let data = (Vytree.get_data[@alert "-exn"]) rtree rpath in
+    match data.node_type with
+    | `Leaf -> if data.multi then `Multi else `Leaf
+    | _ -> (data.node_type :> path_type)
+
+let get_path_type_str ?(legacy_format=false) rtree cpath =
+    let path_typ = get_path_type rtree cpath in
+    if not legacy_format then
+        match path_type_to_yojson path_typ with
+        | `String s -> s
+    else
+    match path_typ with
+    | `Invalid -> "leaf" (* yes, really, that is legacy behavior *)
+    | `Tag_value | `Other -> "non-leaf"
+    | `Tag -> "tag"
+    | `Multi -> "multi"
+    | `Leaf | `Leaf_value -> "leaf"
+
 
 (* The 'edit' command can descend along a not-as-yet configured path,
    assuming that it is