custom.ml 4.47 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 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 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 87 88 89 90 91 92 93 94 95 96 97 98
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 " ]"

module String : T with type t = string = struct
  type t = string
  let dump = Format.pp_print_string
  let check s = ()
  let equal : t -> t -> bool = (=)
  let compare : t -> t -> int = Pervasives.compare
  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

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

99 100
  let serialize t x = Serialize.Put.list X.serialize t x
  let deserialize t = Serialize.Get.list X.deserialize t
101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
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

117 118
  let serialize t x = Serialize.Put.pair X.serialize Y.serialize t x
  let deserialize t = Serialize.Get.pair X.deserialize Y.deserialize t
119
end
120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182

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