custom.ml 5.63 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18
module type T = sig
  type t

  (* Debugging *)
  val dump: Format.formatter -> t -> unit
  val check: t -> unit (* Check internal invariants *)

  (* Data structures *)
  val equal: t -> t -> bool
  val hash: t -> int
  val compare:t -> t -> int
  
  (* Serialization *)
  val serialize: t Serialize.Put.f
  val deserialize: t Serialize.Get.f
end

module Dummy = struct
19 20 21 22 23
  let dump ppf _ = failwith "dump not implemented"
  let check _ = failwith "check not implemented"
  let equal t1 t2 = failwith "equal not implemented"
  let hash t = failwith "hash not implemented"
  let compare t1 t2 = failwith "compare not implemented"
24
  let serialize t = failwith "serialize not implemented" 
25
  let deserialize t = failwith "deserialize not implemented"
26 27 28 29 30 31 32 33 34 35 36 37 38
end

let dump_list ?(sep="; ") f ppf l =
  Format.pp_print_string ppf "[ ";
  (match l with 
     | [] -> ()
     | [hd] -> f ppf hd
     | hd::tl -> 
	 f ppf hd; 
	 List.iter (fun x -> Format.pp_print_string ppf sep; f ppf x) tl
  );
  Format.pp_print_string ppf " ]"

39 40
let dump_array ?(sep="; ") f ppf a = dump_list ~sep f ppf (Array.to_list a)

41 42 43 44
module String : T with type t = string = struct
  type t = string
  let dump = Format.pp_print_string
  let check s = ()
45 46 47 48 49 50 51 52 53 54 55 56 57 58 59

  let rec compare_string_aux s1 s2 l =
    if (l == 0) then 0 
    else
      let l = pred l in
      let c1 = Char.code (String.unsafe_get s1 l)
      and c2 = Char.code (String.unsafe_get s2 l) in
      if c1 != c2 then c2 - c1 else compare_string_aux s1 s2 l

  let compare s1 s2 =
    let l1 = String.length s1 and l2 = String.length s2 in
    if l1 != l2 then l2 - l1 else compare_string_aux s1 s2 l1


  let equal x y = compare x y = 0
60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86
  let hash = Hashtbl.hash
  let serialize = Serialize.Put.string
  let deserialize = Serialize.Get.string
end

module Int : T with type t = int = struct
  type t = int
  let dump = Format.pp_print_int
  let check s = ()
  let equal : t -> t -> bool = (=)
  let compare : t -> t -> int = Pervasives.compare
  let hash x = x
  let serialize = Serialize.Put.int
  let deserialize = Serialize.Get.int
end

module Bool : T with type t = bool = struct
  type t = bool
  let dump = Format.pp_print_bool
  let check s = ()
  let equal : t -> t -> bool = (=)
  let compare : t -> t -> int = Pervasives.compare
  let hash x = if x then 1 else 0
  let serialize = Serialize.Put.bool
  let deserialize = Serialize.Get.bool
end

87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114
module Array(X : T) = struct
  module Elem = X
  type t = X.t array
  let dump = dump_array X.dump
  let check a = Array.iter X.check a

  let rec compare_elems a1 a2 i l =
    if (i = l) then 0
    else
      let c = X.compare a1.(i) a2.(i) in
      if c <> 0 then c else compare_elems a1 a2 (succ i) l

  let compare a1 a2 =
    let l1 = Array.length a1 and l2 = Array.length a2 in
    let c = Pervasives.compare l1 l2 in if c <> 0 then c
    else compare_elems a1 a2 0 l1

  let equal a1 a2 = compare a1 a2 == 0

  let hash a =
    let h = ref (Array.length a) in
    Array.iter (fun x -> h := 17 * !h + X.hash x) a;
    !h
    
  let serialize t x = Serialize.Put.array X.serialize t x
  let deserialize t = Serialize.Get.array X.deserialize t
end

115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141
module List(X : T) = struct
  module Elem = X
  type t = X.t list
  let dump = dump_list X.dump
  let check l = List.iter X.check l

  let rec equal l1 l2 =
    (l1 == l2) ||
    match (l1,l2) with
      | x1::l1, x2::l2 -> (X.equal x1 x2) && (equal l1 l2)
      | _ -> false

  let rec hash accu = function
    | [] -> 1 + accu
    | x::l -> hash (17 * accu + X.hash x) l

  let hash l = hash 1 l

  let rec compare l1 l2 =
    if l1 == l2 then 0 
    else match (l1,l2) with
      | x1::l1, x2::l2 -> 
	  let c = X.compare x1 x2 in if c <> 0 then c 
	  else compare l1 l2
      | [],_ -> -1
      | _ -> 1

142 143
  let serialize t x = Serialize.Put.list X.serialize t x
  let deserialize t = Serialize.Get.list X.deserialize t
144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159
end


module Pair(X : T)(Y : T) = struct
  module Fst = X
  module Snd = Y

  type t = X.t * Y.t
  let dump ppf (x,y) = Format.fprintf ppf "(%a,%a)" X.dump x Y.dump y
  let check (x,y) = X.check x; Y.check y
  let compare (x1,y1) (x2,y2) =
    let c = X.compare x1 x2 in if c <> 0 then c
    else Y.compare y1 y2
  let equal (x1,y1) (x2,y2) = (X.equal x1 x2) && (Y.equal y1 y2)
  let hash (x,y) = X.hash x + 17 * Y.hash y

160 161
  let serialize t x = Serialize.Put.pair X.serialize Y.serialize t x
  let deserialize t = Serialize.Get.pair X.deserialize Y.deserialize t
162
end
163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225

module type Proxy = sig
  include T

  type key
  type content
  type arg

  type 'a spec = {
    content: 'a -> content;
    serialize: 'a Serialize.Put.f;
    deserialize: 'a Serialize.Get.f;
  }

  val register: key -> (arg -> 'a)  -> 'a spec -> unit
  val instantiate: key -> arg -> t
  val content: t -> content
end

module Proxy(Key : T)(Arg : sig type t end)(Content : sig type t end) :
  Proxy with type key = Key.t and type arg = Arg.t and type content = Content.t =
struct
  type key = Key.t
  type arg = Arg.t
  type content = Content.t
  type 'a spec = {
    content: 'a -> Content.t;
    serialize: 'a Serialize.Put.f;
    deserialize: 'a Serialize.Get.f;
  }

  type t = {
    value: content;
    put: Serialize.Put.t -> unit;
  }
  
  include Dummy
  module T = Hashtbl.Make(Key)
  let table = T.create 23

  let register name make spec =
    let f r = {
      value = spec.content r;
      put = (fun s -> Key.serialize s name; spec.serialize s r)
    } in
    let deserialize s = f (spec.deserialize s) in
    T.add table name 
      ((fun arg -> f (make arg)),
       (fun s -> f (spec.deserialize s)))


  let content x = x.value

  let instantiate name (arg : Arg.t) =
    fst (T.find table name) arg

  let serialize s x =
    x.put s

  let deserialize s =
    let name = Key.deserialize s in
    snd (T.find table name) s
end