Commit | Line | Data |
---|---|---|
b1b2de81 C |
1 | (* File: conv.ml |
2 | ||
3 | Copyright (C) 2005- | |
4 | ||
5 | Jane Street Holding, LLC | |
6 | Author: Markus Mottl | |
7 | email: mmottl\@janestcapital.com | |
8 | WWW: http://www.janestcapital.com/ocaml | |
9 | ||
10 | This library is free software; you can redistribute it and/or | |
11 | modify it under the terms of the GNU Lesser General Public | |
12 | License as published by the Free Software Foundation; either | |
13 | version 2 of the License, or (at your option) any later version. | |
14 | ||
15 | This library is distributed in the hope that it will be useful, | |
16 | but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
18 | Lesser General Public License for more details. | |
19 | ||
20 | You should have received a copy of the GNU Lesser General Public | |
21 | License along with this library; if not, write to the Free Software | |
22 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA | |
23 | *) | |
24 | ||
25 | (* Conv: Utility Module for S-expression Conversions *) | |
26 | ||
27 | open Printf | |
28 | open Bigarray | |
29 | open Sexp | |
30 | ||
31 | type 'a sexp_option = 'a option | |
32 | ||
33 | (* Conversion of OCaml-values to S-expressions *) | |
34 | ||
35 | let default_string_of_float = ref (fun n -> sprintf "%.20G" n) | |
36 | let read_old_option_format = ref true | |
37 | let write_old_option_format = ref true | |
38 | ||
39 | let sexp_of_unit () = List [] | |
40 | let sexp_of_bool b = Atom (string_of_bool b) | |
41 | let sexp_of_string str = Atom str | |
42 | let sexp_of_char c = Atom (String.make 1 c) | |
43 | let sexp_of_int n = Atom (string_of_int n) | |
44 | let sexp_of_float n = Atom (!default_string_of_float n) | |
45 | let sexp_of_int32 n = Atom (Int32.to_string n) | |
46 | let sexp_of_int64 n = Atom (Int64.to_string n) | |
47 | let sexp_of_nativeint n = Atom (Nativeint.to_string n) | |
48 | let sexp_of_big_int n = Atom (Big_int.string_of_big_int n) | |
49 | let sexp_of_nat n = Atom (Nat.string_of_nat n) | |
50 | let sexp_of_num n = Atom (Num.string_of_num n) | |
51 | let sexp_of_ratio n = Atom (Ratio.string_of_ratio n) | |
52 | let sexp_of_ref sexp_of__a rf = sexp_of__a !rf | |
53 | let sexp_of_lazy sexp_of__a lv = sexp_of__a (Lazy.force lv) | |
54 | ||
55 | let sexp_of_option sexp_of__a = function | |
56 | | Some x when !write_old_option_format -> List [sexp_of__a x] | |
57 | | Some x -> List [Atom "some"; sexp_of__a x] | |
58 | | None when !write_old_option_format -> List [] | |
59 | | None -> Atom "none" | |
60 | ||
61 | let sexp_of_pair sexp_of__a sexp_of__b (a, b) = | |
62 | List [sexp_of__a a; sexp_of__b b] | |
63 | ||
64 | let sexp_of_triple sexp_of__a sexp_of__b sexp_of__c (a, b, c) = | |
65 | List [sexp_of__a a; sexp_of__b b; sexp_of__c c] | |
66 | ||
67 | let sexp_of_list sexp_of__a lst = | |
68 | List (List.rev (List.rev_map sexp_of__a lst)) | |
69 | ||
70 | let sexp_of_array sexp_of__a ar = | |
71 | let lst_ref = ref [] in | |
72 | for i = Array.length ar - 1 downto 0 do | |
73 | lst_ref := sexp_of__a ar.(i) :: !lst_ref | |
74 | done; | |
75 | List !lst_ref | |
76 | ||
77 | let sexp_of_hashtbl sexp_of_key sexp_of_val htbl = | |
78 | let coll k v acc = List [sexp_of_key k; sexp_of_val v] :: acc in | |
79 | List (Hashtbl.fold coll htbl []) | |
80 | ||
81 | let sexp_of_float_vec vec = | |
82 | let lst_ref = ref [] in | |
83 | for i = Array1.dim vec downto 1 do | |
84 | lst_ref := sexp_of_float vec.{i} :: !lst_ref | |
85 | done; | |
86 | List !lst_ref | |
87 | ||
88 | type vec32 = (float, float32_elt, fortran_layout) Array1.t | |
89 | type vec64 = (float, float64_elt, fortran_layout) Array1.t | |
90 | let sexp_of_float32_vec (vec : vec32) = sexp_of_float_vec vec | |
91 | let sexp_of_float64_vec (vec : vec64) = sexp_of_float_vec vec | |
92 | let sexp_of_vec (vec : vec64) = sexp_of_float_vec vec | |
93 | ||
94 | let sexp_of_float_mat mat = | |
95 | let m = Array2.dim1 mat in | |
96 | let n = Array2.dim2 mat in | |
97 | let lst_ref = ref [] in | |
98 | for col = n downto 1 do | |
99 | let vec = Array2.slice_right mat col in | |
100 | for row = m downto 1 do | |
101 | lst_ref := sexp_of_float vec.{row} :: !lst_ref | |
102 | done | |
103 | done; | |
104 | List (sexp_of_int m :: sexp_of_int n :: !lst_ref) | |
105 | ||
106 | type mat32 = (float, float32_elt, fortran_layout) Array2.t | |
107 | type mat64 = (float, float64_elt, fortran_layout) Array2.t | |
108 | let sexp_of_float32_mat (mat : mat32) = sexp_of_float_mat mat | |
109 | let sexp_of_float64_mat (mat : mat64) = sexp_of_float_mat mat | |
110 | let sexp_of_mat (mat : mat64) = sexp_of_float_mat mat | |
111 | ||
112 | let sexp_of_abstr _ = Atom "<abstr>" | |
113 | let sexp_of_fun _ = Atom "<fun>" | |
114 | ||
115 | type 'a opaque = 'a | |
116 | let sexp_of_opaque _ _ = Atom "<opaque>" | |
117 | ||
118 | let string_of__of__sexp_of to_sexp x = Sexp.to_string (to_sexp x) | |
119 | ||
120 | ||
121 | (* Conversion of S-expressions to OCaml-values *) | |
122 | ||
123 | exception Of_sexp_error of string * Sexp.t | |
124 | ||
125 | let record_check_extra_fields = ref true | |
126 | ||
127 | let of_sexp_error what sexp = raise (Of_sexp_error (what, sexp)) | |
128 | ||
129 | let unit_of_sexp sexp = match sexp with | |
130 | | List [] -> () | |
131 | | Atom _ | List _ -> of_sexp_error "unit_of_sexp: empty list needed" sexp | |
132 | ||
133 | let bool_of_sexp sexp = match sexp with | |
134 | | Atom ("true" | "True") -> true | |
135 | | Atom ("false" | "False") -> false | |
136 | | Atom _ -> of_sexp_error "bool_of_sexp: unknown string" sexp | |
137 | | List _ -> of_sexp_error "bool_of_sexp: atom needed" sexp | |
138 | ||
139 | let string_of_sexp sexp = match sexp with | |
140 | | Atom str -> str | |
141 | | List _ -> of_sexp_error "string_of_sexp: atom needed" sexp | |
142 | ||
143 | let char_of_sexp sexp = match sexp with | |
144 | | Atom str -> | |
145 | if String.length str <> 1 then | |
146 | of_sexp_error | |
147 | "char_of_sexp: atom string must contain one character only" sexp; | |
148 | str.[0] | |
149 | | List _ -> of_sexp_error "char_of_sexp: atom needed" sexp | |
150 | ||
151 | let int_of_sexp sexp = match sexp with | |
152 | | Atom str -> | |
153 | (try int_of_string str | |
154 | with exc -> of_sexp_error ("int_of_sexp: " ^ Printexc.to_string exc) sexp) | |
155 | | List _ -> of_sexp_error "int_of_sexp: atom needed" sexp | |
156 | ||
157 | let float_of_sexp sexp = match sexp with | |
158 | | Atom str -> | |
159 | (try float_of_string str | |
160 | with exc -> | |
161 | of_sexp_error ("float_of_sexp: " ^ Printexc.to_string exc) sexp) | |
162 | | List _ -> of_sexp_error "float_of_sexp: atom needed" sexp | |
163 | ||
164 | let int32_of_sexp sexp = match sexp with | |
165 | | Atom str -> | |
166 | (try Int32.of_string str | |
167 | with exc -> | |
168 | of_sexp_error ("int32_of_sexp: " ^ Printexc.to_string exc) sexp) | |
169 | | List _ -> of_sexp_error "int32_of_sexp: atom needed" sexp | |
170 | ||
171 | let int64_of_sexp sexp = match sexp with | |
172 | | Atom str -> | |
173 | (try Int64.of_string str | |
174 | with exc -> | |
175 | of_sexp_error ("int64_of_sexp: " ^ Printexc.to_string exc) sexp) | |
176 | | List _ -> of_sexp_error "int64_of_sexp: atom needed" sexp | |
177 | ||
178 | let nativeint_of_sexp sexp = match sexp with | |
179 | | Atom str -> | |
180 | (try Nativeint.of_string str | |
181 | with exc -> | |
182 | of_sexp_error ("nativeint_of_sexp: " ^ Printexc.to_string exc) sexp) | |
183 | | List _ -> of_sexp_error "nativeint_of_sexp: atom needed" sexp | |
184 | ||
185 | let big_int_of_sexp sexp = match sexp with | |
186 | | Atom str -> | |
187 | (try Big_int.big_int_of_string str | |
188 | with exc -> | |
189 | of_sexp_error ("big_int_of_sexp: " ^ Printexc.to_string exc) sexp) | |
190 | | List _ -> of_sexp_error "big_int_of_sexp: atom needed" sexp | |
191 | ||
192 | let nat_of_sexp sexp = match sexp with | |
193 | | Atom str -> | |
194 | (try Nat.nat_of_string str | |
195 | with exc -> | |
196 | of_sexp_error ("nat_of_sexp: " ^ Printexc.to_string exc) sexp) | |
197 | | List _ -> of_sexp_error "nat_of_sexp: atom needed" sexp | |
198 | ||
199 | let num_of_sexp sexp = match sexp with | |
200 | | Atom str -> | |
201 | (try Num.num_of_string str | |
202 | with exc -> | |
203 | of_sexp_error ("num_of_sexp: " ^ Printexc.to_string exc) sexp) | |
204 | | List _ -> of_sexp_error "num_of_sexp: atom needed" sexp | |
205 | ||
206 | let ratio_of_sexp sexp = match sexp with | |
207 | | Atom str -> | |
208 | (try Ratio.ratio_of_string str | |
209 | with exc -> | |
210 | of_sexp_error ("ratio_of_sexp: " ^ Printexc.to_string exc) sexp) | |
211 | | List _ -> of_sexp_error "ratio_of_sexp: atom needed" sexp | |
212 | ||
213 | let ref_of_sexp a__of_sexp sexp = ref (a__of_sexp sexp) | |
214 | let lazy_of_sexp a__of_sexp sexp = lazy (a__of_sexp sexp) | |
215 | ||
216 | let option_of_sexp a__of_sexp sexp = | |
217 | if !read_old_option_format then | |
218 | match sexp with | |
219 | | List [] | Atom ("none" | "None") -> None | |
220 | | List [el] | List [Atom ("some" | "Some"); el] -> Some (a__of_sexp el) | |
221 | | List _ -> | |
222 | of_sexp_error "option_of_sexp: list must represent optional value" sexp | |
223 | | Atom _ -> of_sexp_error "option_of_sexp: only none can be atom" sexp | |
224 | else | |
225 | match sexp with | |
226 | | Atom ("none" | "None") -> None | |
227 | | List [Atom ("some" | "Some"); el] -> Some (a__of_sexp el) | |
228 | | Atom _ -> of_sexp_error "option_of_sexp: only none can be atom" sexp | |
229 | | List _ -> of_sexp_error "option_of_sexp: list must be (some el)" sexp | |
230 | ||
231 | let pair_of_sexp a__of_sexp b__of_sexp sexp = match sexp with | |
232 | | List [a_sexp; b_sexp] -> | |
233 | let a = a__of_sexp a_sexp in | |
234 | let b = b__of_sexp b_sexp in | |
235 | a, b | |
236 | | List _ -> | |
237 | of_sexp_error | |
238 | "pair_of_sexp: list must contain exactly two elements only" sexp | |
239 | | Atom _ -> of_sexp_error "pair_of_sexp: list needed" sexp | |
240 | ||
241 | let triple_of_sexp a__of_sexp b__of_sexp c__of_sexp sexp = match sexp with | |
242 | | List [a_sexp; b_sexp; c_sexp] -> | |
243 | let a = a__of_sexp a_sexp in | |
244 | let b = b__of_sexp b_sexp in | |
245 | let c = c__of_sexp c_sexp in | |
246 | a, b, c | |
247 | | List _ -> | |
248 | of_sexp_error | |
249 | "triple_of_sexp: list must contain exactly three elements only" sexp | |
250 | | Atom _ -> of_sexp_error "triple_of_sexp: list needed" sexp | |
251 | ||
252 | let list_of_sexp a__of_sexp sexp = match sexp with | |
253 | | List lst -> | |
254 | let rev_lst = List.rev_map a__of_sexp lst in | |
255 | List.rev rev_lst | |
256 | | Atom _ -> of_sexp_error "list_of_sexp: list needed" sexp | |
257 | ||
258 | let array_of_sexp a__of_sexp sexp = match sexp with | |
259 | | List [] -> [||] | |
260 | | List (h :: t) -> | |
261 | let len = List.length t + 1 in | |
262 | let res = Array.create len (a__of_sexp h) in | |
263 | let rec loop i = function | |
264 | | [] -> res | |
265 | | h :: t -> res.(i) <- a__of_sexp h; loop (i + 1) t in | |
266 | loop 1 t | |
267 | | Atom _ -> of_sexp_error "array_of_sexp: list needed" sexp | |
268 | ||
269 | let hashtbl_of_sexp key_of_sexp val_of_sexp sexp = match sexp with | |
270 | | List lst -> | |
271 | let htbl = Hashtbl.create 0 in | |
272 | let act = function | |
273 | | List [k_sexp; v_sexp] -> | |
274 | Hashtbl.add htbl (key_of_sexp k_sexp) (val_of_sexp v_sexp) | |
275 | | List _ | Atom _ -> | |
276 | of_sexp_error "hashtbl_of_sexp: tuple list needed" sexp | |
277 | in | |
278 | List.iter act lst; | |
279 | htbl | |
280 | | Atom _ -> of_sexp_error "hashtbl_of_sexp: list needed" sexp | |
281 | ||
282 | let float_vec_of_sexp empty_float_vec create_float_vec sexp = match sexp with | |
283 | | List [] -> empty_float_vec | |
284 | | List lst -> | |
285 | let len = List.length lst in | |
286 | let res = create_float_vec len in | |
287 | let rec loop i = function | |
288 | | [] -> res | |
289 | | h :: t -> res.{i} <- float_of_sexp h; loop (i + 1) t in | |
290 | loop 1 lst | |
291 | | Atom _ -> of_sexp_error "float_vec_of_sexp: list needed" sexp | |
292 | ||
293 | let create_float32_vec = Array1.create float32 fortran_layout | |
294 | let create_float64_vec = Array1.create float64 fortran_layout | |
295 | let empty_float32_vec = create_float32_vec 0 | |
296 | let empty_float64_vec = create_float64_vec 0 | |
297 | let float32_vec_of_sexp = float_vec_of_sexp empty_float32_vec create_float32_vec | |
298 | let float64_vec_of_sexp = float_vec_of_sexp empty_float64_vec create_float64_vec | |
299 | let vec_of_sexp = float_vec_of_sexp empty_float64_vec create_float64_vec | |
300 | ||
301 | let check_too_much_data sexp data res = | |
302 | if data = [] then res | |
303 | else of_sexp_error "float_mat_of_sexp: too much data" sexp | |
304 | ||
305 | let float_mat_of_sexp create_float_mat sexp = match sexp with | |
306 | | List (sm :: sn :: data) -> | |
307 | let m = int_of_sexp sm in | |
308 | let n = int_of_sexp sn in | |
309 | let res = create_float_mat m n in | |
310 | if m = 0 || n = 0 then check_too_much_data sexp data res | |
311 | else | |
312 | let rec loop_cols col data = | |
313 | let vec = Array2.slice_right res col in | |
314 | let rec loop_rows row = function | |
315 | | [] -> of_sexp_error "float_mat_of_sexp: not enough data" sexp | |
316 | | h :: t -> | |
317 | vec.{row} <- float_of_sexp h; | |
318 | if row = m then | |
319 | if col = n then check_too_much_data sexp t res | |
320 | else loop_cols (col + 1) t | |
321 | else loop_rows (row + 1) t in | |
322 | loop_rows 1 data in | |
323 | loop_cols 1 data | |
324 | | List _ -> of_sexp_error "float_mat_of_sexp: list too short" sexp | |
325 | | Atom _ -> of_sexp_error "float_mat_of_sexp: list needed" sexp | |
326 | ||
327 | let create_float32_mat = Array2.create float32 fortran_layout | |
328 | let create_float64_mat = Array2.create float64 fortran_layout | |
329 | ||
330 | let float32_mat_of_sexp = float_mat_of_sexp create_float32_mat | |
331 | let float64_mat_of_sexp = float_mat_of_sexp create_float64_mat | |
332 | let mat_of_sexp = float_mat_of_sexp create_float64_mat | |
333 | ||
334 | let fun_of_sexp sexp = | |
335 | of_sexp_error "fun_of_sexp: cannot convert function values" sexp | |
336 | ||
337 | let of_string__of__of_sexp of_sexp s = | |
338 | try | |
339 | let sexp = Sexp.of_string s in | |
340 | of_sexp sexp | |
341 | with e -> | |
342 | failwith (sprintf "of_string failed on %s with %s" s (Printexc.to_string e)) |