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
24
25
  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"
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