Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 193 lines (158 sloc) 5.618 kB
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 (*
19 @author Jérémie Lumbroso
20 @author François-Régis Sinot
21 **)
22
23
24 exception Id_overflow
25
26 (**
27 Name creation, with namespaces.
28
29 Use this generator if you wish to turn various occurrences of, say, ["x"] and ["y"] into
30 ["x0"], ["x1"], ["x2"], ["y0"], ["y1"], ...
31
32 Generate a new unique name.
33
34 Usage: [let fresh ... = let f = fresh_named_factory ?init_size transf in f ...].
35
36 [transf] is any transformer from triple (name, description, index), typically a custom printer
37
38 {b Note} Names produced are guaranteed unique only with respect to each other,
39 and only if your [transf] is consistent with the way you generate new items.
40 In other words, the first name you will obtain by calling [fresh "x" "foo"] is
41 always e.g. ["x_0___AS_foo"].
42 *)
43 type stamp = int
44 type name = string
45 type descr = string
46 type t_fresh = stamp * int * name * descr
47
48 let compare ((l1,_,_,_):t_fresh) (r1,_,_,_) =
49 compare l1 r1 (* the stamp is unique *)
50 let equal ((l1,_,_,_):t_fresh) (r1,_,_,_) =
51 l1 = r1
52 let hash ((i,_,_,_):t_fresh) = Hashtbl.hash i
53
54 let default_print (_,index,name,descr) =
55 Printf.sprintf "%s_%d_%s" name index descr
56
57 let inner_fresh_named_factory ?(init_size=32) transf =
58 let counter = ref (1 : stamp) in
59 let new_stamp () =
60 let stamp = !counter in
61 if stamp < max_int && 0 - stamp > min_int then
62 begin
63 incr counter;
64 stamp
65 end
66 else
67 raise Id_overflow
68 in
69 let table = Hashtbl.create init_size in
70 let rev_table = Hashtbl.create init_size in
71 let next = fun ?(name="") ?(descr="") () ->
72 let key = (name, descr) in
73 let index =
74 try
75 Hashtbl.find table key
76 with
77 Not_found -> (-1)
78 in
79 let index = if index < max_int then index + 1 else raise Id_overflow in
80 Hashtbl.replace table key index;
81 transf (new_stamp (), index, name, descr) in
82
83 (* for the specification, see the comment about [compare] in [FRESH] *)
84 let prev ?(name="") ?(descr="") () =
85 let key = (name, descr) in
86 let index =
87 try
88 Hashtbl.find rev_table key
89 with
90 Not_found -> 0 (* don't start at 1 or else you can create collisions
91 * with the names generated by next *)
92 in
93 let index = if index > min_int then index - 1 else raise Id_overflow in
94 Hashtbl.replace rev_table key index;
95 transf (0 - new_stamp (), index, name, descr) in
96
97 next, prev
98
99 let fresh_named_factory ?(init_size=32) transf =
100 let (next, _) = inner_fresh_named_factory ~init_size transf in
101 next
102
103 let default_fresh_named_factory () =
104 fresh_named_factory default_print
105
106 module type FRESH =
107 sig
108 type t
109 val next : ?name:string -> ?descr:string -> unit -> t
110 val prev : ?name:string -> ?descr:string -> unit -> t
111
112 val compare : t -> t -> int
113 (**
114 values with the same name and descr are guaranteed to be
115 generated in increasing order by [next] and decreasing order by [prev]
116 ie calling [next ~name ~descr] will give you the greatest value with the
117 given name and descr (until you call [next] again) and [prev] will give you
118 the lowest value (until the you [prev] again)
119 *)
120
121 val equal : t -> t -> bool
122 val to_string : t -> string
123 val to_int : t -> int
124 val hash : t -> int
125
126 (**
127 export just the name, e.g. for manual printing
128 This is used for errors messages, we try to print types with
129 the name of type variables as there where in the source code.
130 *)
131 val name : t -> string
132
133 (**
134 This is like a next, but with the property that the name and the description
135 of the fresh is taken from the given fresh.
136 This is used in order not to loose the original names of TypeVariables.
137 *)
138 val refresh : t -> t
139 end
140
141 module type BRAND =
142 sig
143 val printer : t_fresh -> string
144 end
145
146 module DefaultBrand : BRAND =
147 struct
148 let printer (_, id, _, _) =
149 let rec aux count =
150 let count = count / 26
151 and charc = 97 + count mod 26 in
152 let char = String.make 1 (Char.chr charc) in
153 if count = 0 then char
154 else aux (count - 1) ^ char
155 in
156 "'" ^ aux id
157 end
158
159 module FreshGen (Brand : BRAND) : FRESH =
160 struct
161 type t = t_fresh
162
163 let name (_, _, name, _) = name
164 let next, prev = inner_fresh_named_factory (fun t -> t) (* hidden be signature *)
165
166 let refresh (_, _, name, descr) = next ~name ~descr ()
167
168 let hash = hash
169 let compare = compare
170 let equal = equal
171 let to_string = Brand.printer
172 let to_int (stamp, _index, _name, _descr) = stamp
173 end
174
175 (**
176 Some simpler fresh generators without names.
177 *)
178
179 let fresh_factory (transf : int -> 'a) : (unit -> 'a) =
180 let index = ref (-1) in
181 fun () ->
182 if !index < max_int then incr index else raise Id_overflow;
183 transf !index
184
185 (** Example *)
186 (** let get_stringint_fresh = fresh_factory (fun t -> Printf.sprintf "_%010d" t);; *)
187
188 module Int =
189 struct
190 (* global int counter -- better use local, specialized versions rather than this *)
191 let get = fresh_factory (fun t -> t);;
192 end
Something went wrong with that request. Please try again.