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
  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"
  let serialize t = failwith "serialize not implemented"
  let deserialize t = failwith "deserialize not implemented"
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

  let serialize t x = Serialize.Put.list X.serialize t x
  let deserialize t = Serialize.Get.list X.deserialize t
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

  let serialize t x = Serialize.Put.pair X.serialize Y.serialize t x
  let deserialize t = Serialize.Get.pair X.deserialize Y.deserialize t
end

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