plugin/completeMap.ml

   1
   2 (** This modules describes complete (and potentially finite) mappings. *)
   3
   4
   5 (** The signature of the functor's parameter module. *)
   6
   7 module type T = sig
   8   type key
   9   type 'a t
  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
  16   val empty : 'a t
  17   val map   : ('a -> 'b) -> 'a t -> 'b t
  18   val fold  : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
  19 end
  20
  21 (** The result signature of the functor. *)
  22
  23 module type S = sig
  24   type key
  25   type 'a t
  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
  38 end
  39
  40 module Make (T : T) : S with type key = T.key = struct
  41
  42   type key = T.key
  43
  44   type 'a t = ('a * 'a T.t)
  45
  46   let empty a = (a, T.empty)
  47
  48   let find x (a, map) = if T.mem x map then T.find x map else a
  49
  50   let (!!) = find
  51
  52   let upd x b (a, map) = (a, T.add x b map)
  53
  54   let map f (a, map) = (f a, T.map f map)
  55
  56   let keys = T.keys
  57
  58   let fold f cmap a = match T.keys with
  59     | None -> raise (Failure "CompleteMap.fold: not finite domain")
  60     | Some keys ->
  61       List.fold_left (fun res key -> f key (find key cmap) res) a keys
  62
  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)
  68
  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
  73
  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
  78
  79   let to_string string_of_key string_of_a (_, map) =
  80     let f key a res =
  81       res ^ "--KEY\n" ^ (string_of_key key) ^ "\n--VAL\n" ^ (string_of_a a) in
  82     T.fold f map ""
  83
  84 end