Skip to content

Commit

Permalink
Improve some PPX error messages (#924)
Browse files Browse the repository at this point in the history
  • Loading branch information
anmonteiro authored Nov 24, 2023
1 parent 82b6485 commit 70f16d8
Show file tree
Hide file tree
Showing 7 changed files with 52 additions and 38 deletions.
7 changes: 4 additions & 3 deletions ppx/ast_external_process.ml
Original file line number Diff line number Diff line change
Expand Up @@ -74,11 +74,12 @@ let spec_of_ptyp (nolabel : bool) (ptyp : Parsetree.core_type) :
let real_arity = Ast_core_type.get_uncurry_arity ptyp in
match (opt_arity, real_arity) with
| Some arity, None -> Fn_uncurry_arity arity
| None, None -> Error.err ~loc:ptyp.ptyp_loc Canot_infer_arity_by_syntax
| None, None -> Error.err ~loc:ptyp.ptyp_loc Cannot_infer_arity_by_syntax
| None, Some arity -> Fn_uncurry_arity arity
| Some arity, Some n ->
if n <> arity then
Error.err ~loc:ptyp.ptyp_loc (Inconsistent_arity (arity, n))
Error.err ~loc:ptyp.ptyp_loc
(Inconsistent_arity { uncurry_attribute = arity; real = n })
else Fn_uncurry_arity arity)
| `Nothing -> (
match ptyp_desc with
Expand Down Expand Up @@ -171,7 +172,7 @@ let refine_obj_arg_type ~(nolabel : bool) (ptyp : Parsetree.core_type) :
else (* ([`a|`b] [@string]) *)
spec_of_ptyp nolabel ptyp

(* Given the type of argument, process its [bs.] attribute and new type,
(* Given the type of argument, process its [mel.*] attribute and new type,
The new type is currently used to reconstruct the external type
and result type in [@@obj]
They are not the same though, for example
Expand Down
63 changes: 37 additions & 26 deletions ppx/error.ml
Original file line number Diff line number Diff line change
Expand Up @@ -38,9 +38,9 @@ type t =
| Invalid_mel_int_type
| Invalid_mel_unwrap_type
| Conflict_ffi_attribute of string
| Canot_infer_arity_by_syntax
| Cannot_infer_arity_by_syntax
| Illegal_attribute
| Inconsistent_arity of int * int
| Inconsistent_arity of { uncurry_attribute : int; real : int }
(* we still require users to have explicit annotation to avoid
{[ (((int -> int) -> int) -> int )]} *)
| Not_supported_directive_in_mel_return
Expand All @@ -54,42 +54,53 @@ let pp_error fmt err =
Format.pp_print_string fmt
(match err with
| Mel_uncurried_arity_too_large ->
"Uncurried functions only supports only up to arity 22"
"Uncurried function arity is limited to 22 arguments"
| Misplaced_label_syntax ->
(* let fn x = ((##) x ~hi) ~lo:1 ~hi:2 *)
"Label syntax is not supported in this position"
(* let fn x = ((##) x ~hi) ~lo:1 ~hi:2 *)
| Optional_in_uncurried_mel_attribute ->
"Uncurried function doesn't support optional arguments yet"
| Expect_opt_in_mel_return_to_opt ->
"@return directive *_to_opt expect return type to be syntax wise `_ \
option` for safety"
| Not_supported_directive_in_mel_return -> "Not supported return directive"
"`@mel.return' directive *_to_opt expects the return type to be an \
option literal type (`_ option')"
| Not_supported_directive_in_mel_return ->
"Unsupported `@mel.return' directive. Supported directives are one of:@\n\
- undefined_to_opt@\n\
- null_to_opt@\n\
- nullable / null_undefined_to_opt@\n\
- identity"
| Illegal_attribute -> "Illegal attributes"
| Canot_infer_arity_by_syntax ->
"Cannot infer the arity through the syntax, either [@uncurry n] or \
write it in arrow syntax"
| Inconsistent_arity (arity, n) ->
Printf.sprintf "Inconsistent arity %d vs %d" arity n
| Unsupported_predicates -> "unsupported predicates"
| Cannot_infer_arity_by_syntax ->
"Cannot infer arity through syntax.@\n\
Use either `[@mel.uncurry n]' or the full arrow type"
| Inconsistent_arity { uncurry_attribute; real } ->
Printf.sprintf
"Inconsistent arity: `[@mel.uncurry %d]' / arrow syntax with `%d' \
arguments"
uncurry_attribute real
| Unsupported_predicates -> "Unsupported predicate"
| Conflict_u_mel_this_mel_meth ->
"@this, @bs, @meth can not be applied at the same time"
| Conflict_attributes -> "conflicting attributes"
| Expect_string_literal -> "expect string literal"
| Duplicated_mel_as -> "duplicate @as"
| Expect_int_literal -> "expect int literal"
"`@mel.this', `@u' and `@mel.meth' cannot be applied at the same time"
| Conflict_attributes -> "Conflicting attributes"
| Expect_string_literal -> "Expected a string literal"
| Duplicated_mel_as -> "Duplicate `@mel.as'"
| Expect_int_literal -> "Expected an integer literal"
| Expect_int_or_string_or_json_literal ->
"expect int, string literal or json literal {json|text here|json}"
| Unhandled_poly_type -> "Unhandled poly type"
"Expected an integer, string or JSON literal (`{json|text here|json}')"
| Unhandled_poly_type -> "Unhandled polymorphic variant type"
| Invalid_underscore_type_in_external ->
"_ is not allowed in combination with external optional type"
| Invalid_mel_string_type -> "Not a valid type for @string"
| Invalid_mel_int_type -> "Not a valid type for @int"
"`_' is not allowed in an `external' declaration's optionally labelled \
argument type"
| Invalid_mel_string_type -> "Invalid type for `@mel.string'"
| Invalid_mel_int_type -> "Invalid type for `@mel.int'"
| Invalid_mel_unwrap_type ->
"Not a valid type for @unwrap. Type must be an inline variant \
"Invalid type for `@mel.unwrap'. Type must be an inline variant \
(closed), and each constructor must have an argument."
| Conflict_ffi_attribute str -> "Conflicting attributes: " ^ str
| Conflict_ffi_attribute str ->
Format.sprintf "Conflicting FFI attributes: %s" str
| Mel_this_simple_pattern ->
"@this expect its pattern variable to be simple form")
"`@mel.this' expects a simple pattern: an optionally constrained \
variable (or wildcard)")

let err ~loc error = Location.raise_errorf ~loc "%a" pp_error error

Expand Down
4 changes: 2 additions & 2 deletions ppx/error.mli
Original file line number Diff line number Diff line change
Expand Up @@ -38,9 +38,9 @@ type t =
| Invalid_mel_int_type
| Invalid_mel_unwrap_type
| Conflict_ffi_attribute of string
| Canot_infer_arity_by_syntax
| Cannot_infer_arity_by_syntax
| Illegal_attribute
| Inconsistent_arity of int * int
| Inconsistent_arity of { uncurry_attribute : int; real : int }
(* we still rqeuire users to have explicit annotation to avoid
{[ (((int -> int) -> int) -> int )]}
*)
Expand Down
4 changes: 2 additions & 2 deletions test/blackbox-tests/as-without-mel-string.t
Original file line number Diff line number Diff line change
Expand Up @@ -55,7 +55,7 @@ Test `@mel.as` without `@mel.string` / `@mel.int` in external polyvars
File "x.ml", line 6, characters 13-24:
6 | | `easeOut [@mel.as 1]
^^^^^^^^^^^
Error: expect string literal
Error: Expected a string literal
[2]
$ cat > x.ml <<EOF
Expand All @@ -73,6 +73,6 @@ Test `@mel.as` without `@mel.string` / `@mel.int` in external polyvars
File "x.ml", line 5, characters 4-43:
5 | | `easeIn [@mel.as 1] [@mel.as "ease-in"]
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: duplicate @as
Error: Duplicate `@mel.as'
[2]
4 changes: 2 additions & 2 deletions test/blackbox-tests/ffi-error-debug.t
Original file line number Diff line number Diff line change
Expand Up @@ -49,7 +49,7 @@ Each [@mel.unwrap] variant constructor requires an argument
File "x.ml", line 2, characters 20-36:
2 | ?hi_should_error:([`a of int | `b] [@mel.unwrap]) ->
^^^^^^^^^^^^^^^^
Error: Not a valid type for @unwrap. Type must be an inline variant (closed),
and each constructor must have an argument.
Error: Invalid type for `@mel.unwrap'. Type must be an inline variant
(closed), and each constructor must have an argument.
[2]

6 changes: 4 additions & 2 deletions test/blackbox-tests/legacy-ounit-cmd.t
Original file line number Diff line number Diff line change
Expand Up @@ -148,12 +148,14 @@ Skip over the temporary file name printed in the error trace
$ melc -ppx melppx -bs-eval 'let should_fail = fun [@mel.this] (Some x) y u -> y + u' 2>&1 | grep -v File
1 | let should_fail = fun [@mel.this] (Some x) y u -> y + u
^^^^^^^^
Error: @this expect its pattern variable to be simple form
Error: `@mel.this' expects a simple pattern: an optionally constrained
variable (or wildcard)
$ melc -ppx melppx -bs-eval 'let should_fail = fun [@mel.this] (Some x as v) y u -> y + u' 2>&1 | grep -v File
1 | let should_fail = fun [@mel.this] (Some x as v) y u -> y + u
^^^^^^^^^^^^^
Error: @this expect its pattern variable to be simple form
Error: `@mel.this' expects a simple pattern: an optionally constrained
variable (or wildcard)
$ cat > x.ml <<EOF
> (* let rec must be rejected *)
Expand Down
2 changes: 1 addition & 1 deletion test/blackbox-tests/mel-as-string-warnings.t
Original file line number Diff line number Diff line change
Expand Up @@ -63,5 +63,5 @@ The analog case with `@mel.int` fails to build
File "x.ml", line 1, characters 16-31:
1 | external foo : ([ `foo of int ][@mel.int]) -> string = "foo"
^^^^^^^^^^^^^^^
Error: Not a valid type for @int
Error: Invalid type for `@mel.int'
[2]

0 comments on commit 70f16d8

Please sign in to comment.