diff --git a/ppx/ast_external_process.ml b/ppx/ast_external_process.ml index 66a15a0a84..e490a3be46 100644 --- a/ppx/ast_external_process.ml +++ b/ppx/ast_external_process.ml @@ -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 @@ -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 diff --git a/ppx/error.ml b/ppx/error.ml index 9234172ab8..18793b1f92 100644 --- a/ppx/error.ml +++ b/ppx/error.ml @@ -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 @@ -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 diff --git a/ppx/error.mli b/ppx/error.mli index f2b530d5cd..e56e0ed41a 100644 --- a/ppx/error.mli +++ b/ppx/error.mli @@ -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 )]} *) diff --git a/test/blackbox-tests/as-without-mel-string.t b/test/blackbox-tests/as-without-mel-string.t index a7737d9538..22d3f10671 100644 --- a/test/blackbox-tests/as-without-mel-string.t +++ b/test/blackbox-tests/as-without-mel-string.t @@ -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 < ^^^^^^^^^^^^^^^^ - 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] diff --git a/test/blackbox-tests/legacy-ounit-cmd.t b/test/blackbox-tests/legacy-ounit-cmd.t index 9bece3c2ca..0367551164 100644 --- a/test/blackbox-tests/legacy-ounit-cmd.t +++ b/test/blackbox-tests/legacy-ounit-cmd.t @@ -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 < (* let rec must be rejected *) diff --git a/test/blackbox-tests/mel-as-string-warnings.t b/test/blackbox-tests/mel-as-string-warnings.t index 5ce253607c..2e85b0159a 100644 --- a/test/blackbox-tests/mel-as-string-warnings.t +++ b/test/blackbox-tests/mel-as-string-warnings.t @@ -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]