@@ -21,7 +21,7 @@ type t = {
anonymous: (Unix.file_descr, Connection.t) Hashtbl.t;
domains: (int, Connection.t) Hashtbl.t;
ports: (Xeneventchn.t, Connection.t) Hashtbl.t;
- mutable watches: (string, Connection.watch list) Trie.t;
+ mutable watches: Connection.watch list Trie.t;
}
let create () = {
@@ -31,9 +31,9 @@ let equal a b =
(* compare using physical equality, both members have to be part of the above weak table *)
a == b
-let compare a b =
- if equal a b then 0
- else -(String.compare a b)
+(* the sort order is reversed here, so that Map.fold constructs a list
+ in ascending order *)
+let compare a b = String.compare b a
let stats () =
let len, entries, _, _, _, _ = WeakTable.stats tbl in
@@ -15,24 +15,26 @@
open Stdext
+module StringMap = Map.Make(String)
+
module Node =
struct
- type ('a,'b) t = {
- key: 'a;
- value: 'b option;
- children: ('a,'b) t list;
+ type 'a t = {
+ key: string;
+ value: 'a option;
+ children: 'a t StringMap.t;
}
let _create key value = {
key = key;
value = Some value;
- children = [];
+ children = StringMap.empty;
}
let empty key = {
key = key;
value = None;
- children = []
+ children = StringMap.empty;
}
let _get_key node = node.key
@@ -49,41 +51,31 @@ struct
{ node with children = children }
let _add_child node child =
- { node with children = child :: node.children }
+ { node with children = StringMap.add child.key child node.children }
end
-type ('a,'b) t = ('a,'b) Node.t list
+type 'a t = 'a Node.t StringMap.t
let mem_node nodes key =
- List.exists (fun n -> n.Node.key = key) nodes
+ StringMap.mem key nodes
let find_node nodes key =
- List.find (fun n -> n.Node.key = key) nodes
+ StringMap.find key nodes
let replace_node nodes key node =
- let rec aux = function
- | [] -> []
- | h :: tl when h.Node.key = key -> node :: tl
- | h :: tl -> h :: aux tl
- in
- aux nodes
+ StringMap.update key (function None -> None | Some _ -> Some node) nodes
let remove_node nodes key =
- let rec aux = function
- | [] -> raise Not_found
- | h :: tl when h.Node.key = key -> tl
- | h :: tl -> h :: aux tl
- in
- aux nodes
+ StringMap.update key (function None -> raise Not_found | Some _ -> None) nodes
-let create () = []
+let create () = StringMap.empty
let rec iter f tree =
- let aux node =
- f node.Node.key node.Node.value;
+ let aux key node =
+ f key node.Node.value;
iter f node.Node.children
in
- List.iter aux tree
+ StringMap.iter aux tree
let rec map f tree =
let aux node =
@@ -94,13 +86,14 @@ let rec map f tree =
in
{ node with Node.value = value; Node.children = map f node.Node.children }
in
- List.filter (fun n -> n.Node.value <> None || n.Node.children <> []) (List.map aux tree)
+ tree |> StringMap.map aux
+ |> StringMap.filter (fun _ n -> n.Node.value <> None || not (StringMap.is_empty n.Node.children) )
let rec fold f tree acc =
- let aux accu node =
- fold f node.Node.children (f node.Node.key node.Node.value accu)
+ let aux key node accu =
+ fold f node.Node.children (f key node.Node.value accu)
in
- List.fold_left aux acc tree
+ StringMap.fold aux tree acc
(* return a sub-trie *)
let rec sub_node tree = function
@@ -117,7 +110,7 @@ let rec sub_node tree = function
let sub tree path =
try (sub_node tree path).Node.children
- with Not_found -> []
+ with Not_found -> StringMap.empty
let find tree path =
Node.get_value (sub_node tree path)
@@ -161,7 +154,7 @@ and set tree path value =
replace_node tree h (set_node node t value)
end else begin
let node = Node.empty h in
- set_node node t value :: tree
+ StringMap.add node.Node.key (set_node node t value) tree
end
let rec unset tree = function
@@ -176,7 +169,7 @@ let rec unset tree = function
then Node.set_children (Node.empty h) children
else Node.set_children node children
in
- if children = [] && new_node.Node.value = None
+ if StringMap.is_empty children && new_node.Node.value = None
then remove_node tree h
else replace_node tree h new_node
end else
@@ -15,46 +15,46 @@
(** Basic Implementation of polymorphic tries (ie. prefix trees) *)
-type ('a, 'b) t
-(** The type of tries. ['a list] is the type of keys, ['b] the type of values.
+type 'a t
+(** The type of tries. ['a] the type of values.
Internally, a trie is represented as a labeled tree, where node contains values
- of type ['a * 'b option]. *)
+ of type [string * 'a option]. *)
-val create : unit -> ('a,'b) t
+val create : unit -> 'a t
(** Creates an empty trie. *)
-val mem : ('a,'b) t -> 'a list -> bool
+val mem : 'a t -> string list -> bool
(** [mem t k] returns true if a value is associated with the key [k] in the trie [t].
Otherwise, it returns false. *)
-val find : ('a, 'b) t -> 'a list -> 'b
+val find : 'a t -> string list -> 'a
(** [find t k] returns the value associated with the key [k] in the trie [t].
Returns [Not_found] if no values are associated with [k] in [t]. *)
-val set : ('a, 'b) t -> 'a list -> 'b -> ('a, 'b) t
+val set : 'a t -> string list -> 'a -> 'a t
(** [set t k v] associates the value [v] with the key [k] in the trie [t]. *)
-val unset : ('a, 'b) t -> 'a list -> ('a, 'b) t
+val unset : 'a t -> string list -> 'a t
(** [unset k v] removes the association of value [v] with the key [k] in the trie [t].
Moreover, it automatically clean the trie, ie. it removes recursively
every nodes of [t] containing no values and having no chil. *)
-val iter : ('a -> 'b option -> unit) -> ('a, 'b) t -> unit
+val iter : (string -> 'a option -> unit) -> 'a t -> unit
(** [iter f t] applies the function [f] to every node of the trie [t].
As nodes of the trie [t] do not necessary contains a value, the second argument of
[f] is an option type. *)
-val iter_path : ('a -> 'b option -> unit) -> ('a, 'b) t -> 'a list -> unit
+val iter_path : (string -> 'a option -> unit) -> 'a t -> string list -> unit
(** [iter_path f t p] iterates [f] over nodes associated with the path [p] in the trie [t].
If [p] is not a valid path of [t], it iterates on the longest valid prefix of [p]. *)
-val fold : ('a -> 'b option -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c
+val fold : (string -> 'a option -> 'c -> 'c) -> 'a t -> 'c -> 'c
(** [fold f t x] fold [f] over every nodes of [t], with [x] as initial value. *)
-val map : ('b -> 'c option) -> ('a,'b) t -> ('a,'c) t
+val map : ('a -> 'b option) -> 'a t -> 'b t
(** [map f t] maps [f] over every values stored in [t]. The return value of [f] is of type 'c option
as one may wants to remove value associated to a key. This function is not tail-recursive. *)
-val sub : ('a, 'b) t -> 'a list -> ('a,'b) t
+val sub : 'a t -> string list -> 'a t
(** [sub t p] returns the sub-trie associated with the path [p] in the trie [t].
If [p] is not a valid path of [t], it returns an empty trie. *)