Source file `sexp_conv_error.ml`

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
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
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
(* Conv_error: Module for Handling Errors during Automated S-expression
   Conversions *)

open StdLabels
open Printf
open Sexp_conv

exception Of_sexp_error = Of_sexp_error

(* Errors concerning tuples *)

let tuple_of_size_n_expected loc n sexp =
  of_sexp_error (sprintf "%s_of_sexp: tuple of size %d expected" loc n) sexp
;;

(* Errors concerning sum types *)

let stag_no_args loc sexp =
  of_sexp_error (loc ^ "_of_sexp: this constructor does not take arguments") sexp
;;

let stag_incorrect_n_args loc tag sexp =
  let msg = sprintf "%s_of_sexp: sum tag %S has incorrect number of arguments" loc tag in
  of_sexp_error msg sexp
;;

let stag_takes_args loc sexp =
  of_sexp_error (loc ^ "_of_sexp: this constructor requires arguments") sexp
;;

let nested_list_invalid_sum loc sexp =
  of_sexp_error (loc ^ "_of_sexp: expected a variant type, saw a nested list") sexp
;;

let empty_list_invalid_sum loc sexp =
  of_sexp_error (loc ^ "_of_sexp: expected a variant type, saw an empty list") sexp
;;

let unexpected_stag loc sexp =
  of_sexp_error (loc ^ "_of_sexp: unexpected variant constructor") sexp
;;

(* Errors concerning records *)

let record_sexp_bool_with_payload loc sexp =
  let msg =
    loc ^ "_of_sexp: record conversion: a [sexp.bool] field was given a payload."
  in
  of_sexp_error msg sexp
;;

let record_only_pairs_expected loc sexp =
  let msg =
    loc
    ^ "_of_sexp: record conversion: only pairs expected, their first element must be an \
       atom"
  in
  of_sexp_error msg sexp
;;

let record_superfluous_fields ~what ~loc rev_fld_names sexp =
  let fld_names_str = String.concat (List.rev rev_fld_names) ~sep:" " in
  let msg = sprintf "%s_of_sexp: %s: %s" loc what fld_names_str in
  of_sexp_error msg sexp
;;

let record_duplicate_fields loc rev_fld_names sexp =
  record_superfluous_fields ~what:"duplicate fields" ~loc rev_fld_names sexp
;;

let record_extra_fields loc rev_fld_names sexp =
  record_superfluous_fields ~what:"extra fields" ~loc rev_fld_names sexp
;;

let rec record_get_undefined_loop fields = function
  | [] -> String.concat (List.rev fields) ~sep:" "
  | (true, field) :: rest -> record_get_undefined_loop (field :: fields) rest
  | _ :: rest -> record_get_undefined_loop fields rest
;;

let record_undefined_elements loc sexp lst =
  let undefined = record_get_undefined_loop [] lst in
  let msg =
    sprintf "%s_of_sexp: the following record elements were undefined: %s" loc undefined
  in
  of_sexp_error msg sexp
;;

let record_list_instead_atom loc sexp =
  let msg = loc ^ "_of_sexp: list instead of atom for record expected" in
  of_sexp_error msg sexp
;;

let record_poly_field_value loc sexp =
  let msg =
    loc
    ^ "_of_sexp: cannot convert values of types resulting from polymorphic record fields"
  in
  of_sexp_error msg sexp
;;

(* Errors concerning polymorphic variants *)

exception No_variant_match

let no_variant_match () = raise No_variant_match

let no_matching_variant_found loc sexp =
  of_sexp_error (loc ^ "_of_sexp: no matching variant found") sexp
;;

let ptag_no_args loc sexp =
  of_sexp_error (loc ^ "_of_sexp: polymorphic variant does not take arguments") sexp
;;

let ptag_incorrect_n_args loc cnstr sexp =
  let msg =
    sprintf
      "%s_of_sexp: polymorphic variant tag %S has incorrect number of arguments"
      loc
      cnstr
  in
  of_sexp_error msg sexp
;;

let ptag_takes_args loc sexp =
  of_sexp_error (loc ^ "_of_sexp: polymorphic variant tag takes an argument") sexp
;;

let nested_list_invalid_poly_var loc sexp =
  of_sexp_error (loc ^ "_of_sexp: a nested list is an invalid polymorphic variant") sexp
;;

let empty_list_invalid_poly_var loc sexp =
  of_sexp_error (loc ^ "_of_sexp: the empty list is an invalid polymorphic variant") sexp
;;

let empty_type loc sexp =
  of_sexp_error (loc ^ "_of_sexp: trying to convert an empty type") sexp
;;