diff options
Diffstat (limited to 'src/config_tree.ml')
| -rw-r--r-- | src/config_tree.ml | 345 |
1 files changed, 0 insertions, 345 deletions
diff --git a/src/config_tree.ml b/src/config_tree.ml deleted file mode 100644 index 28cfcdd..0000000 --- a/src/config_tree.ml +++ /dev/null @@ -1,345 +0,0 @@ -type value_behaviour = AddValue | ReplaceValue - -exception Duplicate_value -exception Node_has_no_value -exception No_such_value -exception Useless_set - -type config_node_data = { - values: string list; - comment: string option; - inactive: bool; - ephemeral: bool; -} [@@deriving yojson] - -type t = config_node_data Vytree.t [@@deriving yojson] - -let default_data = { - values = []; - comment = None; - inactive = false; - ephemeral = false; -} - -let make name = Vytree.make default_data name - -let replace_value node path value = - let data = {default_data with values=[value]} in - Vytree.update node path data - -let add_value node path value = - let node' = Vytree.get node path in - let data = Vytree.data_of_node node' in - let values = data.values in - match (Vylist.find (fun x -> x = value) values) with - | Some _ -> raise Duplicate_value - | None -> - let values = values @ [value] in - Vytree.update node path ({data with values=values}) - -let delete_value node path value = - let data = Vytree.data_of_node @@ Vytree.get node path in - let values = Vylist.remove (fun x -> x = value) data.values in - Vytree.update node path {data with values=values} - -let set_value node path value behaviour = - match behaviour with - | AddValue -> add_value node path value - | ReplaceValue -> replace_value node path value - -let set node path value behaviour = - if (Vytree.exists node path) then - (match value with - | None -> raise Useless_set - | Some v -> set_value node path v behaviour) - else - let path_existing = Vytree.get_existent_path node path in - let path_remaining = Vylist.complement path path_existing in - let values = match value with None -> [] | Some v -> [v] in - Vytree.insert_multi_level default_data node path_existing path_remaining {default_data with values=values} - -let get_values node path = - let node' = Vytree.get node path in - let data = Vytree.data_of_node node' in - data.values - -let get_value node path = - let values = get_values node path in - match values with - | [] -> raise Node_has_no_value - | x :: _ -> x - -let delete node path value = - match value with - | Some v -> - (let values = get_values node path in - if Vylist.in_list values v then - (match values with - | [_] -> Vytree.delete node path - | _ -> delete_value node path v) - else raise No_such_value) - | None -> - Vytree.delete node path - -let set_comment node path comment = - let data = Vytree.get_data node path in - Vytree.update node path {data with comment=comment} - -let get_comment node path = - let data = Vytree.get_data node path in - data.comment - -let set_inactive node path inactive = - let data = Vytree.get_data node path in - Vytree.update node path {data with inactive=inactive} - -let is_inactive node path = - let data = Vytree.get_data node path in - data.inactive - -let set_ephemeral node path ephemeral = - let data = Vytree.get_data node path in - Vytree.update node path {data with ephemeral=ephemeral} - -let is_ephemeral node path = - let data = Vytree.get_data node path in - data.ephemeral - -module Renderer = -struct - (* TODO Replace use of Printf with Format *) - - module L = List - module S = String - module PF = Printf - module VT = Vytree - module RT = Reference_tree - - (* Nodes are ordered based on a comarison of their names *) - let compare cmp node1 node2 = - let name1 = VT.name_of_node node1 in - let name2 = VT.name_of_node node2 in - cmp name1 name2 - - let indentation indent level = S.make (level * indent) ' ' - - let render_inactive data = if data.inactive then "#INACTIVE " else "" - let render_ephemeral data = if data.ephemeral then "#EPHEMERAL " else "" - - let render_comment data indents = - match data.comment with - | None -> "" - (* Trailing indentation for the rest of the material on the next line *) - | Some c -> PF.sprintf "/*%s*/\n%s" c indents - - let render_tag = function - | None -> "" - | Some tag -> PF.sprintf "%s " tag - - let render_outer indents data name tag = - [render_comment data indents ; - render_inactive data; - render_ephemeral data; - render_tag tag; - name] - |> S.concat "" - - let render_values ?(valueless=false) values = - let quote_if_needed s = - try - let _ = Pcre.exec ~pat:"[\\s;{}#\\[\\]\"\']" s in - Printf.sprintf "\"%s\"" s - with Not_found -> s - in - match values with - | [] -> if valueless then ";" else "{ }" - | [v] -> PF.sprintf "%s;" (quote_if_needed v) - | _ as vs -> S.concat "; " (List.map quote_if_needed vs) |> PF.sprintf "[%s];" - - let render_inner_and_outer indents inner outer = - if inner = "" - (* Hidden or empty descendents yield empty nodes *) - then PF.sprintf "%s%s { }" indents outer - else PF.sprintf "%s%s %s" indents outer inner - - let render - ?(indent=4) - ?(reftree=None) - ?(cmp=BatString.numeric_compare) - ?(showephemeral=false) - ?(showinactive=false) - (config_tree:t) - = - let is_hidden data = - (not showephemeral && data.ephemeral) || - (not showinactive && data.inactive) - in - let rec render_node level ?tag node = - let data = VT.data_of_node node in - let name = VT.name_of_node node in - (* Hide inactive and ephemeral when necessary *) - if is_hidden data then "" - else - let indents = indentation indent level in - let outer = render_outer indents data name tag in - let inner = (* Children are ignored if the node has values *) - match data.values with - | [] -> VT.children_of_node node |> render_children level - | values -> render_values values - in - PF.sprintf "%s%s %s" indents outer inner - and render_children level = function - | [] -> "{ }" - | children -> - let indents = indentation indent level in - let render_child node = render_node (level + 1) node in - let rendered_children = L.map render_child children |> S.concat "\n" - in - if rendered_children = "" then "{ }" - else PF.sprintf "{\n%s\n%s}" rendered_children indents - in - (* Walks the reftree and config_tree side-by-side *) - let rec render_node_rt level tag rt node = - let data = VT.data_of_node node in - let name = VT.name_of_node node in - let rt_data = VT.data_of_node rt in - let rt_name = VT.name_of_node rt in - (* Hide inactive and ephemeral when necessary *) - if is_hidden data then "" - else - (* TODO refactor this ugly approach*) - let (outer_name, level', inner) = - let open RT in - let children = VT.children_of_node node in - let ordered = rt_data.keep_order in - match rt_data.node_type with - | Tag -> - ("", 0, render_children_rt level (Some name) ordered rt children) - | Other -> - (name, level, render_children_rt level None ordered rt children) - | Leaf -> - (name, level, render_values ~valueless:rt_data.valueless data.values) - in - let indents = indentation indent level' in - let outer = render_outer indents data outer_name tag in - (* Do not insert a space before ; for valueless nodes *) - if rt_data.valueless then PF.sprintf "%s%s%s" indents outer inner - else PF.sprintf "%s%s %s" indents outer inner - and render_children_rt level tag ordered rt = function - | [] -> "{ }" - | children -> - let is_tagged = BatOption.is_some tag in - let indents = indentation indent level in - let reorder nodes = - if ordered then nodes - else L.sort (compare cmp) nodes - in - let render_child node = - let level' = if is_tagged then level else level + 1 in - let node_reftree = VT.find rt (VT.name_of_node node) in - (* If there is no reftree for a node, default to stand-alone *) - match node_reftree with - | Some rt' -> render_node_rt level' tag rt' node - | None -> render_node level' ?tag node - in - let rendered_children = children - |> reorder - |> L.map render_child - |> S.concat "\n" - in - if rendered_children = "" then "{ }" - else if is_tagged - then rendered_children - else PF.sprintf "{\n%s\n%s}" rendered_children indents - in - match reftree with - | None -> render_node 0 config_tree - | Some rt -> render_node_rt 0 None rt config_tree - - - (* Rendering configs as set commands *) - let render_set_path path value = - let v = Printf.sprintf "\'%s\'" value in - List.append path [v] |> String.concat " " |> Printf.sprintf "set %s" - - let rec render_commands ?(reftree=None) ?(alwayssort=false) path ct = - let new_path = List.append path [Vytree.name_of_node ct] in - let new_path_str = String.concat " " new_path in - let data = Vytree.data_of_node ct in - (* Get the node comment, if any *) - let comment = BatOption.default "" data.comment in - let comment_cmd = (if comment = "" then "" else Printf.sprintf "comment %s \'%s\'" new_path_str comment) in - (* Sort child names, if required *) - let child_names = Vytree.list_children ct in - let child_names = - begin - match reftree with - | Some rt -> - if ((RT.get_keep_order rt path) && (not alwayssort)) then child_names - else (List.sort BatString.numeric_compare child_names) - | None -> - if alwayssort then (List.sort BatString.numeric_compare child_names) - else child_names - end - in - (* Now handle the different cases for nodes with and without children *) - match child_names with - | [] -> - (* This is a leaf node *) - let values = List.map String.escaped data.values in - let cmds = - begin - match values with - | [] -> - (* Valueless leaf node *) - String.concat " " new_path |> Printf.sprintf "set %s" - | [v] -> - (* Single value, just one command *) - render_set_path new_path v - | vs -> - (* A leaf node with multiple values *) - List.map (render_set_path new_path) vs |> String.concat "\n" - end - in - if comment_cmd = "" then cmds else Printf.sprintf "%s\n%s" cmds comment_cmd - | children -> - (* A node with children *) - let children = List.map (fun n -> Vytree.get ct [n]) child_names in - let rendered_children = List.map (render_commands ~reftree:reftree ~alwayssort:alwayssort new_path) children in - let cmds = String.concat "\n" rendered_children in - if comment_cmd = "" then cmds else Printf.sprintf "%s\n%s" cmds comment_cmd - - -end (* Renderer *) - -let render = Renderer.render - -let render_at_level - ?(indent=4) - ?(reftree=None) - ?(cmp=BatString.numeric_compare) - ?(showephemeral=false) - ?(showinactive=false) - node - path = - let node = - match path with - | [] -> node - | _ -> Vytree.get node path - in - let children = Vytree.children_of_node node in - let child_configs = List.map (render ~indent:indent ~reftree:reftree ~cmp:cmp ~showephemeral:showephemeral ~showinactive:showinactive) children in - String.concat "\n" child_configs - -let render_commands ?(reftree=None) ?(alwayssort=false) ?(sortchildren=false) node path = - let node = - match path with - | [] -> node - | _ -> Vytree.get node path - in - let children = - if sortchildren then Vytree.sorted_children_of_node (BatString.numeric_compare) node - else Vytree.children_of_node node - in - let commands = List.map (Renderer.render_commands ~reftree:reftree ~alwayssort:alwayssort path) children in - String.concat "\n" commands |