2 (** This modules describes complete (and potentially finite) mappings. *)
5 (** The signature of the functor's parameter module. *)
10 (** [keys] needs to be given for finite mappings, and needs to be [None] for
11 non finite mappings. *)
12 val keys : key list option
13 val mem : key -> 'a t -> bool
14 val find : key -> 'a t -> 'a
15 val add : key -> 'a -> 'a t -> 'a t
17 val map : ('a -> 'b) -> 'a t -> 'b t
18 val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
21 (** The result signature of the functor. *)
26 val empty : 'a -> 'a t
27 val find : key -> 'a t -> 'a
28 val upd : key -> 'a -> 'a t -> 'a t
29 val map : ('a -> 'b) -> 'a t -> 'b t
30 (** Keys in case of finite mappings. *)
31 val keys : key list option
32 (** Only works on [keys]. Raises [Failure "CompleteMap.fold: not finite
33 domain"] is no keys. *)
34 val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
35 val merge : ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t
36 val cmp : ('a -> 'b -> bool -> bool) -> 'a t -> 'b t -> bool -> bool
37 val to_string : (key -> string) -> ('a -> string) -> 'a t -> string
40 module Make (T : T) : S with type key = T.key = struct
44 type 'a t = ('a * 'a T.t)
46 let empty a = (a, T.empty)
48 let find x (a, map) = if T.mem x map then T.find x map else a
52 let upd x b (a, map) = (a, T.add x b map)
54 let map f (a, map) = (f a, T.map f map)
58 let fold f cmap a = match T.keys with
59 | None -> raise (Failure "CompleteMap.fold: not finite domain")
61 List.fold_left (fun res key -> f key (find key cmap) res) a keys
63 let f_merge f_default f_map ((a1, map1) as cmap1) ((a2, map2) as cmap2) a =
64 let f1 x v1 a = f_map x v1 (find x cmap2) a in
65 let f2 x v2 a = f_map x (find x cmap1) v2 a in
66 let a = T.fold f1 map1 a in
67 f_default a1 a2 (T.fold f2 map2 a)
69 let merge f cmap1 cmap2 =
70 let f_default a1 a2 map = (f a1 a2, map) in
71 let f_map x v1 v2 map = T.add x (f v1 v2) map in
72 f_merge f_default f_map cmap1 cmap2 T.empty
74 let cmp f cmap1 cmap2 a =
75 let f_default a1 a2 a = f a1 a2 a in
76 let f_map _ v1 v2 a = f v1 v2 a in
77 f_merge f_default f_map cmap1 cmap2 a
79 let to_string string_of_key string_of_a (_, map) =
81 res ^ "--KEY\n" ^ (string_of_key key) ^ "\n--VAL\n" ^ (string_of_a a) in