ocamlsexp/conv.ml

   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))