Merge pull request #59 from jestabro/vyconf-completion-env

T8061: Add analogues of cli-shell-api completion functions

4 files changed, 328 insertions, 63 deletions

diff --git a/src/completion.ml b/src/completion.ml
new file mode 100644
index 0000000..4b84a99
--- /dev/null
+++ b/src/completion.ml
@@ -0,0 +1,166 @@
+type op_type = Set | Delete | Show | Comment | Unknown
+
+let op_of_string op_str =
+    match op_str with
+    | "set" -> Set
+    | "delete" -> Delete
+    | "show" -> Show
+    | "comment" -> Comment
+    | _ -> Unknown
+
+type completion_env = {
+    name: string;
+    path_typ: Reference_tree.path_type;
+    values: string list;
+    completion_help: Reference_tree.completion_help_type list;
+    help: string;
+    value_help: (string * string) list;
+    multi: bool;
+} [@@deriving yojson]
+
+type completion_env_list = completion_env list [@@deriving yojson]
+
+let get_completion_data (node: Reference_tree.t) =
+    let name = Vytree.name_of_node node in
+    let data = Vytree.data_of_node node in
+    { name=name;
+      values=[];
+      path_typ=`Other;
+      multi=data.multi;
+      completion_help=data.completion_help;
+      help=data.help;
+      value_help=data.value_help;
+    }
+
+let get_completion_env rtree ctree op cpath =
+    let op = op_of_string op in
+    match op with
+    | Unknown -> Error {|Unknown operation|}
+    | _ ->
+    let restricted =
+        match op with
+        | Delete | Show | Comment -> true
+        | _ -> false
+    in
+    let last = Util.get_last cpath in
+    let last_elt =
+        match last with
+        | None -> ""
+        | Some c -> c
+    in
+    let path = Util.drop_last cpath in
+    let path_typ = Reference_tree.get_path_type rtree path in
+    let rpath = Reference_tree.refpath rtree path in
+    if restricted && not (Util.is_empty path) && not ((Vytree.exists[@alert "-exn"]) ctree path)
+    then Error {|Nonexistent path|}
+    else
+    match path_typ with
+    | `Invalid -> Error {|Invalid path|}
+    | `Leaf_value -> Error {|Leaf value|}
+    | `Leaf | `Multi ->
+        let compl_env =
+            get_completion_data ((Vytree.get[@alert "-exn"]) rtree rpath) in
+        let values =
+            try
+                (Config_tree.get_values[@alert "-exn"]) ctree path
+            with Vytree.Nonexistent_path -> []
+        in
+        Ok [{ compl_env with values = values; path_typ = `Leaf_value }]
+    | `Tag ->
+        let compl_env =
+            get_completion_data ((Vytree.get[@alert "-exn"]) rtree rpath)
+        in
+        let values =
+            try
+                Vytree.list_children ((Vytree.get[@alert "-exn"]) ctree path)
+            with Vytree.Nonexistent_path -> []
+        in
+        Ok [{ compl_env with values = values; path_typ = `Tag_value }]
+    | _ ->
+        let rnode =
+            match rpath with
+            | [] -> rtree
+            | _ -> (Vytree.get[@alert "-exn"]) rtree rpath
+        in
+        let cnode =
+            match path with
+            | [] -> ctree
+            | _ -> (Vytree.get[@alert "-exn"]) ctree path
+        in
+        let children =
+            let child_set = Vytree.children_of_node rnode in
+            if not restricted then child_set
+            else
+            let extant_children =
+                try
+                    Vytree.list_children cnode
+                with Vytree.Nonexistent_path -> []
+            in
+            let is_extant s =
+                List.mem (Vytree.name_of_node s) extant_children
+            in
+            List.filter is_extant child_set
+        in
+        let children' =
+            let get_match s =
+                String.starts_with ~prefix:last_elt (Vytree.name_of_node s)
+            in
+            List.filter get_match children
+        in
+        let aux node' =
+            let compl_env = get_completion_data node' in
+            let name = Vytree.name_of_node node' in
+            let path_typ = Reference_tree.get_path_type rtree (path @ [name]) in
+            { compl_env with values = [name]; path_typ = path_typ }
+        in
+        Ok (List.map aux children')
+
+let get_completion_env_str ?(legacy_format=false) rtree ctree op cpath =
+    let compl_env = get_completion_env rtree ctree op cpath in
+    match compl_env with
+    | Error e -> Error e
+    | Ok comp ->
+        if not legacy_format then
+            Ok (completion_env_list_to_yojson comp |> Yojson.Safe.to_string)
+        else
+        (* produce the strings expected by vbash completion *)
+        let path_typ = Reference_tree.get_path_type rtree (Util.drop_last cpath) in
+        let func (compl_vals, compl_help, help, value_help) comp_env =
+            compl_vals @ comp_env.values,
+            compl_help @ comp_env.completion_help,
+            help @ [comp_env.help],
+            value_help @ comp_env.value_help
+        in
+        let (comp_vals, comp_val, comp_help, help_format, help_string) =
+        match path_typ with
+        | `Tag | `Leaf | `Multi ->
+            let (compl_vals, _, _, value_help) =
+                let a, b, c, d =
+                    List.fold_left func ([], [], [], []) comp in
+                List.rev a, b, c, List.rev d
+            in
+            let value_help_fmt, value_help_string = List.split value_help in
+            (compl_vals, true, "", value_help_fmt, value_help_string)
+        | `Other | `Tag_value ->
+            let (compl_vals, _, help, _) =
+                let sorted_comp =
+                    let sort s t = Util.lexical_numeric_compare s.name t.name
+                    in List.sort sort comp
+                in List.fold_left func ([], [], [], []) sorted_comp
+            in
+            (compl_vals, false, "", compl_vals, help)
+        | _ -> ([], false, "", [], []) (* never reached *)
+        in
+        let print_help_list l =
+            {|(|}^
+            (String.concat " " (List.map (Printf.sprintf {|'%s'|}) l))^
+            {|)|}
+        in
+        let res =
+        (Printf.sprintf {|_cli_shell_api_comp_values=%s; |} (print_help_list comp_vals))^
+        (Printf.sprintf {|_cli_shell_api_last_comp_val=%b; |} comp_val)^
+        (Printf.sprintf {|_cli_shell_api_comp_help='%s'; |} comp_help)^
+        (Printf.sprintf {|_cli_shell_api_hitems=%s; |} (print_help_list help_format))^
+        (Printf.sprintf {|_cli_shell_api_hstrs=%s;|} (print_help_list help_string))
+        in Ok res
+
diff --git a/src/completion.mli b/src/completion.mli
new file mode 100644
index 0000000..fb53fef
--- /dev/null
+++ b/src/completion.mli
@@ -0,0 +1,18 @@
+type completion_env = {
+    name: string;
+    path_typ: Reference_tree.path_type;
+    values: string list;
+    completion_help: Reference_tree.completion_help_type list;
+    help: string;
+    value_help: (string * string) list;
+    multi: bool;
+} [@@deriving yojson]
+
+type completion_env_list = completion_env list [@@deriving yojson]
+
+val get_completion_data : Reference_tree.t -> completion_env
+
+val get_completion_env : Reference_tree.t -> Config_tree.t -> string -> string list -> (completion_env_list, string) result
+
+val get_completion_env_str : ?legacy_format:bool -> Reference_tree.t -> Config_tree.t -> string -> string list -> (string, string) result
+
diff --git a/src/reference_tree.ml b/src/reference_tree.ml
index afde451..81e45cf 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 =
@@ -578,31 +591,39 @@ let get_value_help reftree path =
     let data = (Vytree.get_data[@alert "-exn"]) reftree path in
     data.value_help
 
-let get_completion_data reftree path =
+let get_default_value reftree path =
     (* raises:
         [Vytree.Empty_path]
         [Vytree.Nonexistent_path]
-       alert exn Vytree.get:
+       alert exn Vytree.get_data:
         [Vytree.Empty_path] allow raise
         [Vytree.Nonexistent_path] allow raise
      *)
-    let aux node =
-        let data = Vytree.data_of_node node in
-        (data.node_type, data.multi, data.help)
-    in
-    List.map aux (Vytree.children_of_node @@ (Vytree.get[@alert "-exn"]) reftree path)
+    let data = (Vytree.get_data[@alert "-exn"]) reftree path in
+    data.default_value
 
 (* Convert from config path to reference tree path *)
 let refpath reftree path =
-    (* raises:
-        [Vytree.Nonexistent_path] from is_tag
-     *)
+    let check_existence p =
+        match p with
+        | [] -> false
+        | _ -> (Vytree.exists[@alert "-exn"]) reftree p
+    in
     let rec aux acc p =
     match acc, p with
-    | [], h :: tl -> aux (acc @ [h]) tl
-    | _, [h] -> if is_tag reftree acc then acc else acc @ [h]
-    | _, h :: h' :: tl -> if is_tag reftree acc then aux (acc @ [h']) tl
-                          else aux (acc @ [h]) ([h'] @ tl)
+    | [], h :: tl ->
+            if check_existence [h] then aux [h] tl else []
+    | _, [h] ->
+            if is_tag reftree acc then acc else
+                let p = acc @ [h] in
+                if check_existence p then p else []
+    | _, h :: h' :: tl ->
+            if is_tag reftree acc then
+                let p = acc @ [h'] in
+                if check_existence p then aux p tl else []
+            else
+                let p = acc @ [h] in
+                if check_existence p then aux p ([h'] @ tl) else []
     | _, [] -> acc
     in aux [] path
 
@@ -649,37 +670,90 @@ let set_leaf_data rtree ctree path =
 let potential_tag_value rtree cpath =
     (* check given path against reftree for potential to be tag value
      *)
+    (* raises:
+        [Vytree.Nonexistent_path] from refpath; is_tag
+     *)
     match cpath with
     | [] | [_] -> false
     | _ ->
+    let refp = refpath rtree cpath in
     let ref_drop_last = refpath rtree (Util.drop_last cpath) in
-    if is_tag rtree ref_drop_last then true
-    else false
+    match ref_drop_last with
+    | [] -> false
+    | _ as c when c = refp -> is_tag rtree refp
+    | _ -> false
+
+let potential_leaf_value rtree cpath =
+    (* check given path against reftree for potential to be leaf value
+     *)
+    (* raises:
+        [Vytree.Nonexistent_path] from refpath; is_leaf
+     *)
+    match cpath with
+    | [] | [_] -> false
+    | _ ->
+    let ref_drop_last = refpath rtree (Util.drop_last cpath) in
+    match ref_drop_last with
+    | [] -> false
+    | _ -> is_leaf rtree ref_drop_last
+
+let reference_path_exists rtree cpath =
+    if Util.is_empty cpath then false
+    else
+    if potential_leaf_value rtree cpath then true
+    else
+    let rpath = refpath rtree cpath in
+    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
    (1) a valid path of the reference tree
    (2) neither a tag nor leaf node
-   To confirm (2) in the case of a tag node, one has to allow for a
-   'potential' tag value as final element of the path.
  *)
 let allowed_edit_level rtree path =
-    try
-        let refp = refpath rtree path
-        in
-        if Util.is_empty refp then
-            Error "The \"edit\" command cannot be issued at an empty path"
-        else
-        if is_tag rtree refp && not (potential_tag_value rtree path)
-        then
-            Error "The \"edit\" command cannot be issued at the level of tag node"
-        else
-        if is_leaf rtree refp
-        then
-            Error "The \"edit\" command cannot be issued at the level of leaf node"
-        else Ok ()
-    with Vytree.Nonexistent_path ->
-        Error "The \"edit\" command cannot be issued at a non-existent path of the reference tree"
+    if Util.is_empty path then
+        Error {|The "edit" command cannot be issued at an empty path|}
+    else
+    match get_path_type rtree path with
+    | `Invalid ->
+        Error {|The "edit" command cannot be issued at a non-existent path of the reference tree|}
+    | `Tag ->
+        Error {|The "edit" command cannot be issued at the level of tag node|}
+    | `Leaf ->
+        Error {|The "edit" command cannot be issued at the level of leaf node|}
+    | `Leaf_value ->
+        Error {|The "edit" command cannot be issued at the level of leaf value|}
+    | _ -> Ok ()
 
 let get_ceil_data f reftree path =
     (* raises:
diff --git a/src/reference_tree.mli b/src/reference_tree.mli
index c2805ae..96cb24f 100644
--- a/src/reference_tree.mli
+++ b/src/reference_tree.mli
@@ -1,7 +1,9 @@
-type node_type =
-    | Leaf
-    | Tag
-    | Other
+type node_type = [ `Leaf | `Tag | `Other ]
+
+type path_type = [ node_type | `Tag_value | `Leaf_value | `Multi | `Invalid ]
+
+val path_type_to_yojson : path_type -> Yojson.Safe.t
+val path_type_of_yojson : Yojson.Safe.t -> (path_type, string) result
 
 type completion_help_type =
     | List of string [@name "list"]
@@ -104,12 +106,11 @@ val get_value_help : t -> string list -> (string * string) list
 [@@alert exn "Vytree.Empty_path"]
 [@@alert exn "Vytree.Nonexistent_path"]
 
-val get_completion_data : t -> string list -> (node_type * bool * string) list
+val get_default_value : t -> string list -> string option
 [@@alert exn "Vytree.Empty_path"]
 [@@alert exn "Vytree.Nonexistent_path"]
 
 val refpath : t -> string list -> string list
-[@@alert exn "Vytree.Nonexistent_path"]
 
 val set_tag_data : t -> Config_tree.t -> string list -> Config_tree.t
 [@@alert exn "Vytree.Empty_path"]
@@ -119,6 +120,12 @@ val set_leaf_data : t -> Config_tree.t -> string list -> Config_tree.t
 [@@alert exn "Vytree.Empty_path"]
 [@@alert exn "Vytree.Nonexistent_path"]
 
+val reference_path_exists : t -> string list -> bool
+
+val get_path_type : t -> string list -> path_type
+
+val get_path_type_str : ?legacy_format:bool -> t -> string list -> string
+
 val allowed_edit_level : t -> string list -> (unit, string) result
 
 val get_ceil_data : (ref_node_data -> string option) -> t -> string list -> string option