HCoop / bpt / coccinelle.git / blame
| Commit | Line | Data |
|---|---|---|
| feec80c3 C |
1 | (****************************************************************************** |
| 2 | * Sexplib * | |
| 3 | * * | |
| 4 | * Copyright (C) 2005- Jane Street Holding, LLC * | |
| 5 | * Contact: opensource@janestreet.com * | |
| 6 | * WWW: http://www.janestreet.com/ocaml * | |
| 7 | * Author: Markus Mottl * | |
| 8 | * * | |
| 9 | * This library is free software; you can redistribute it and/or * | |
| 10 | * modify it under the terms of the GNU Lesser General Public * | |
| 11 | * License as published by the Free Software Foundation; either * | |
| 12 | * version 2 of the License, or (at your option) any later version. * | |
| 13 | * * | |
| 14 | * This library is distributed in the hope that it will be useful, * | |
| 15 | * but WITHOUT ANY WARRANTY; without even the implied warranty of * | |
| 16 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * | |
| 17 | * Lesser General Public License for more details. * | |
| 18 | * * | |
| 19 | * You should have received a copy of the GNU Lesser General Public * | |
| 20 | * License along with this library; if not, write to the Free Software * | |
| 21 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * | |
| 22 | * * | |
| 23 | ******************************************************************************) | |
| b1b2de81 C |
24 | |
| 25 | (* Conv_error: Module for Handling Errors during Automated S-expression | |
| 26 | Conversions *) | |
| 27 | ||
| 28 | open Printf | |
| 29 | open Conv | |
| 30 | ||
| 31 | (* Errors concerning tuples *) | |
| 32 | ||
| 33 | let tuple_of_size_n_expected loc n sexp = | |
| 34 | of_sexp_error (sprintf "%s_of_sexp: tuple of size %d expected" loc n) sexp | |
| 35 | ||
| 36 | ||
| 37 | (* Errors concerning sum types *) | |
| 38 | ||
| 39 | let stag_no_args loc sexp = | |
| 40 | of_sexp_error (loc ^ "_of_sexp: sum tag does not take arguments") sexp | |
| 41 | ||
| 42 | let stag_incorrect_n_args loc tag sexp = | |
| 43 | let msg = | |
| 44 | sprintf "%s_of_sexp: sum tag %S has incorrect number of arguments" loc tag | |
| 45 | in | |
| 46 | of_sexp_error msg sexp | |
| 47 | ||
| 48 | let stag_takes_args loc sexp = | |
| 49 | of_sexp_error (loc ^ "_of_sexp: sum tag must be a structured value") sexp | |
| 50 | ||
| 51 | let nested_list_invalid_sum loc sexp = | |
| 52 | of_sexp_error (loc ^ "_of_sexp: a nested list is an invalid sum") sexp | |
| 53 | ||
| 54 | let empty_list_invalid_sum loc sexp = | |
| 55 | of_sexp_error (loc ^ "_of_sexp: the empty list is an invalid sum") sexp | |
| 56 | ||
| 57 | let unexpected_stag loc sexp = | |
| 58 | of_sexp_error (loc ^ "_of_sexp: unexpected sum tag") sexp | |
| 59 | ||
| 60 | ||
| 61 | (* Errors concerning records *) | |
| 62 | ||
| 63 | let record_only_pairs_expected loc sexp = | |
| 64 | let msg = | |
| 65 | loc ^ | |
| 66 | "_of_sexp: record conversion: only pairs expected, \ | |
| 67 | their first element must be an atom" in | |
| 68 | of_sexp_error msg sexp | |
| 69 | ||
| 70 | let record_superfluous_fields ~what ~loc rev_fld_names sexp = | |
| 71 | let fld_names_str = String.concat " " (List.rev rev_fld_names) in | |
| 72 | let msg = sprintf "%s_of_sexp: %s: %s" loc what fld_names_str in | |
| 73 | of_sexp_error msg sexp | |
| 74 | ||
| 75 | let record_duplicate_fields loc rev_fld_names sexp = | |
| 76 | record_superfluous_fields ~what:"duplicate fields" ~loc rev_fld_names sexp | |
| 77 | ||
| 78 | let record_extra_fields loc rev_fld_names sexp = | |
| 79 | record_superfluous_fields ~what:"extra fields" ~loc rev_fld_names sexp | |
| 80 | ||
| 81 | let rec record_get_undefined_loop fields = function | |
| 82 | | [] -> String.concat " " (List.rev fields) | |
| 83 | | (true, field) :: rest -> record_get_undefined_loop (field :: fields) rest | |
| 84 | | _ :: rest -> record_get_undefined_loop fields rest | |
| 85 | ||
| 86 | let record_undefined_elements loc sexp lst = | |
| 87 | let undefined = record_get_undefined_loop [] lst in | |
| 88 | let msg = | |
| 89 | sprintf "%s_of_sexp: the following record elements were undefined: %s" | |
| 90 | loc undefined | |
| 91 | in | |
| 92 | of_sexp_error msg sexp | |
| 93 | ||
| 94 | let record_list_instead_atom loc sexp = | |
| 95 | let msg = loc ^ "_of_sexp: list instead of atom for record expected" in | |
| 96 | of_sexp_error msg sexp | |
| 97 | ||
| 98 | let record_poly_field_value loc sexp = | |
| 99 | let msg = | |
| 100 | loc ^ | |
| 101 | "_of_sexp: cannot convert values of types resulting from polymorphic \ | |
| 102 | record fields" | |
| 103 | in | |
| 104 | of_sexp_error msg sexp | |
| 105 | ||
| 106 | ||
| 107 | (* Errors concerning polymorphic variants *) | |
| 108 | ||
| 109 | exception No_variant_match of string * Sexp.t | |
| 110 | ||
| 111 | let no_variant_match loc sexp = | |
| 112 | raise (No_variant_match (loc ^ "_of_sexp", sexp)) | |
| 113 | ||
| feec80c3 C |
114 | let no_matching_variant_found loc sexp = |
| 115 | of_sexp_error (loc ^ ": no matching variant found") sexp | |
| 116 | ||
| b1b2de81 C |
117 | let ptag_no_args loc sexp = |
| 118 | of_sexp_error ( | |
| 119 | loc ^ "_of_sexp: polymorphic variant does not take arguments") sexp | |
| 120 | ||
| 121 | let ptag_incorrect_n_args loc cnstr sexp = | |
| 122 | let msg = | |
| 123 | sprintf | |
| 124 | "%s_of_sexp: polymorphic variant tag %S has incorrect number of arguments" | |
| 125 | loc cnstr | |
| 126 | in | |
| 127 | of_sexp_error msg sexp | |
| 128 | ||
| 129 | let nested_list_invalid_poly_var loc sexp = | |
| 130 | of_sexp_error ( | |
| 131 | loc ^ "_of_sexp: a nested list is an invalid polymorphic variant") sexp | |
| 132 | ||
| 133 | let empty_list_invalid_poly_var loc sexp = | |
| 134 | of_sexp_error ( | |
| 135 | loc ^ "_of_sexp: the empty list is an invalid polymorphic variant") sexp | |
| 136 | ||
| 137 | let silly_type loc sexp = | |
| 138 | of_sexp_error (loc ^ "_of_sexp: trying to convert a silly type") sexp | |
| 139 | ||
| 140 | let empty_type loc sexp = | |
| 141 | of_sexp_error (loc ^ "_of_sexp: trying to convert an empty type") sexp |