diff options
| -rw-r--r-- | src/reference_tree.ml | 178 | ||||
| -rw-r--r-- | src/reference_tree.mli | 54 |
2 files changed, 232 insertions, 0 deletions
diff --git a/src/reference_tree.ml b/src/reference_tree.ml new file mode 100644 index 0000000..cfafaa5 --- /dev/null +++ b/src/reference_tree.ml @@ -0,0 +1,178 @@ +type node_type = Leaf | Tag | Other + +type value_constraint = + | Regex of string [@name "regex"] + | External of string * string option [@name "exec"] + [@@deriving yojson] + +type ref_node_data = { + node_type: node_type; + constraints: value_constraint list; + help: string; + value_help: (string * string) list; + constraint_error_message: string; + multi: bool; + valueless: bool; + owner: string option; + keep_order: bool; + hidden: bool; + secret: bool; +} + +type t = ref_node_data Vytree.t + +exception Bad_interface_definition of string + +exception Validation_error of string + +let default_data = { + node_type = Other; + constraints = []; + help = "No help available"; + value_help = []; + constraint_error_message = "Invalid value"; + multi = false; + valueless = false; + owner = None; + keep_order = false; + hidden = false; + secret = false; +} + +let default = Vytree.make default_data "root" + +(* Loading from XML *) + +let node_type_of_string s = + match s with + | "node" -> Other + | "tagNode" -> Tag + | "leafNode" -> Leaf + | _ -> raise (Bad_interface_definition + (Printf.sprintf "node, tagNode, or leafNode expected, %s found" s)) + +let load_constraint_from_xml d c = + let aux d c = + match c with + | Xml.Element ("regex", _, [Xml.PCData s]) -> + let cs = (Regex s) :: d.constraints in + {d with constraints=cs} + | Xml.Element ("validator", [("name", n); ("argument", a)], _) -> + let cs = (External (n, Some a)) :: d.constraints in + {d with constraints=cs} + | Xml.Element ("validator", [("name", n)], _) -> + let cs = (External (n, None)) :: d.constraints in + {d with constraints=cs} + | _ -> raise (Bad_interface_definition "Malformed constraint") + in Xml.fold aux d c + +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 ("multi", _, _) -> {d with multi=true} + | Xml.Element ("valueless", _, _) -> {d with valueless=true} + | Xml.Element ("constraintErrorMessage", _, [Xml.PCData s]) -> + {d with constraint_error_message=s} + | Xml.Element ("constraint", _, _) -> load_constraint_from_xml d x + | Xml.Element ("hidden", _, _) -> {d with hidden=true} + | Xml.Element ("secret", _, _) -> {d with secret=true} + | Xml.Element ("keepChildOrder", _, _) -> {d with keep_order=true} + | _ -> raise (Bad_interface_definition "Malformed property tag") + in Xml.fold aux d x + +let rec insert_from_xml basepath reftree xml = + match xml with + | Xml.Element (tag, _, _) -> + let props = Util.find_xml_child "properties" xml in + let data = + (match props with + | None -> default_data + | Some p -> data_from_xml default_data p) + in + let node_type = node_type_of_string (Xml.tag xml) in + let node_owner = try let o = Xml.attrib xml "owner" in Some o + with _ -> None + in + let data = {data with node_type=node_type; owner=node_owner} in + let name = Xml.attrib xml "name" in + let path = basepath @ [name] in + let new_tree = Vytree.insert reftree path data in + (match node_type with + | Leaf -> new_tree + | _ -> + let children = Util.find_xml_child "children" xml in + (match children with + | None -> raise (Bad_interface_definition (Printf.sprintf "Node %s has no children" name)) + | Some c -> List.fold_left (insert_from_xml path) new_tree (Xml.children c))) + | _ -> raise (Bad_interface_definition "PCData not allowed here") + +let load_from_xml reftree file = + let xml_to_reftree xml reftree = + match xml with + | Xml.Element ("interfaceDefinition", attrs, children) -> + List.fold_left (insert_from_xml []) reftree children + | _ -> raise (Bad_interface_definition "Should start with <interfaceDefinition>") + in + try + let xml = Xml.parse_file file in + xml_to_reftree xml reftree + with + | Xml.File_not_found msg -> raise (Bad_interface_definition msg) + | Xml.Error e -> raise (Bad_interface_definition (Xml.error e)) + +let is_multi reftree path = + let data = Vytree.get_data reftree path in + data.multi + +let is_hidden reftree path = + let data = Vytree.get_data reftree path in + data.hidden + +let is_secret reftree path = + let data = Vytree.get_data reftree path in + data.secret + +let is_tag reftree path = + let data = Vytree.get_data reftree path in + match data.node_type with + | Tag -> true + | _ -> false + +let is_leaf reftree path = + let data = Vytree.get_data reftree path in + match data.node_type with + | Leaf -> true + | _ -> false + +let is_valueless reftree path = + let data = Vytree.get_data reftree path in + data.valueless + +let get_keep_order reftree path = + let data = Vytree.get_data reftree path in + data.keep_order + +let get_owner reftree path = + let data = Vytree.get_data reftree path in + data.owner + +let get_help_string reftree path = + let data = Vytree.get_data reftree path in + data.help + +let get_value_help reftree path = + let data = Vytree.get_data reftree path in + data.value_help + +let get_completion_data reftree path = + 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 reftree path) diff --git a/src/reference_tree.mli b/src/reference_tree.mli new file mode 100644 index 0000000..eab9fe9 --- /dev/null +++ b/src/reference_tree.mli @@ -0,0 +1,54 @@ +type node_type = Leaf | Tag | Other + +type value_constraint = + | Regex of string [@name "regex"] + | External of string * string option [@name "exec"] + [@@deriving yojson] + +type ref_node_data = { + node_type: node_type; + constraints: value_constraint list; + help: string; + value_help: (string * string) list; + constraint_error_message: string; + multi: bool; + valueless: bool; + owner: string option; + keep_order: bool; + hidden: bool; + secret: bool; +} + +exception Bad_interface_definition of string + +exception Validation_error of string + +type t = ref_node_data Vytree.t + +val default_data : ref_node_data + +val default : t + +val load_from_xml : t -> string -> t + +val is_multi : t -> string list -> bool + +val is_hidden : t -> string list -> bool + +val is_secret : t -> string list -> bool + +val is_tag : t -> string list -> bool + +val is_leaf : t -> string list -> bool + +val is_valueless : t -> string list -> bool + +val get_keep_order : t -> string list -> bool + +val get_owner : t -> string list -> string option + +val get_help_string : t -> string list -> string + +val get_value_help : t -> string list -> (string * string) list + +val get_completion_data : t -> string list -> (node_type * bool * string) list |