Skip to content

Commit cf252f1

Browse files
alanechangalanechang
committed
support for error_message attr on layout annots
add error_message to the builtin_attrs table change error_message_attr to return first refactor - layout_of_annotation_or_attr to layout_of_annotation - Err_msg_attr to With_error_message fix tests improve formatting
1 parent 95dc0bd commit cf252f1

11 files changed

+386
-28
lines changed

‎ocaml/parsing/builtin_attributes.ml

Lines changed: 16 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -104,6 +104,7 @@ let builtin_attrs =
104104
; "loop"; "ocaml.loop"
105105
; "tail_mod_cons"; "ocaml.tail_mod_cons"
106106
; "unaliasable"; "ocaml.unaliasable"
107+
; "error_message"; "ocaml.error_message"
107108
]
108109

109110
(* nroberts: When we upstream the builtin-attribute whitelisting, we shouldn't
@@ -665,3 +666,18 @@ let tailcall attr =
665666
(Warnings.Attribute_payload
666667
(t.attr_name.txt, "Only 'hint' is supported"));
667668
Ok (Some `Tail_if_possible)
669+
670+
let error_message_attr l =
671+
let inner x =
672+
match x.attr_name.txt with
673+
| "ocaml.error_message"|"error_message" ->
674+
begin match string_of_payload x.attr_payload with
675+
| Some _ as r ->
676+
mark_used x.attr_name;
677+
r
678+
| None -> warn_payload x.attr_loc x.attr_name.txt
679+
"error_message attribute expects a string argument";
680+
None
681+
end
682+
| _ -> None in
683+
List.find_map inner l

‎ocaml/parsing/builtin_attributes.mli

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -204,3 +204,10 @@ val has_once : Parsetree.attributes -> (bool, unit) result
204204
val layout : legacy_immediate:bool -> Parsetree.attributes ->
205205
(Jane_asttypes.layout_annotation option,
206206
Jane_asttypes.layout_annotation) result
207+
208+
(** Finds the first "error_message" attribute, marks it as used, and returns its
209+
string payload. Returns [None] if no such attribute is present.
210+
211+
There should be at most one "error_message" attribute, additional ones are sliently
212+
ignored. **)
213+
val error_message_attr : Parsetree.attributes -> string option

‎ocaml/testsuite/tests/typing-layouts/error_message_attr.ml

Lines changed: 156 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,156 @@
1+
(* TEST
2+
flags = "-extension layouts_alpha"
3+
* expect
4+
*)
5+
6+
module Float_u = Stdlib__Float_u
7+
8+
[%%expect{|
9+
module Float_u = Stdlib__Float_u
10+
|}]
11+
12+
(* Needs a string payload *)
13+
14+
let f (v: float#): ((_ : value)[@error_message]) = v
15+
[%%expect{|
16+
Line 1, characters 31-47:
17+
1 | let f (v: float#): ((_ : value)[@error_message]) = v
18+
^^^^^^^^^^^^^^^^
19+
Warning 47 [attribute-payload]: illegal payload for attribute 'error_message'.
20+
error_message attribute expects a string argument
21+
Line 1, characters 51-52:
22+
1 | let f (v: float#): ((_ : value)[@error_message]) = v
23+
^
24+
Error: This expression has type float# but an expression was expected of type
25+
('a : value)
26+
The layout of float# is float64, because
27+
it is the primitive float64 type float#.
28+
But the layout of float# must be a sublayout of value, because
29+
of the annotation on the wildcard _ at line 1, characters 20-31.
30+
|}]
31+
32+
let f (v: float#): ((_ : value)[@error_message 1]) = v
33+
[%%expect{|
34+
Line 1, characters 31-49:
35+
1 | let f (v: float#): ((_ : value)[@error_message 1]) = v
36+
^^^^^^^^^^^^^^^^^^
37+
Warning 47 [attribute-payload]: illegal payload for attribute 'error_message'.
38+
error_message attribute expects a string argument
39+
Line 1, characters 53-54:
40+
1 | let f (v: float#): ((_ : value)[@error_message 1]) = v
41+
^
42+
Error: This expression has type float# but an expression was expected of type
43+
('a : value)
44+
The layout of float# is float64, because
45+
it is the primitive float64 type float#.
46+
But the layout of float# must be a sublayout of value, because
47+
of the annotation on the wildcard _ at line 1, characters 20-31.
48+
|}]
49+
50+
(* Ltyp_var { name = None; layout } case *)
51+
let f (v: float#): ((_ : value)[@error_message "Custom message"]) = v
52+
[%%expect{|
53+
Line 1, characters 68-69:
54+
1 | let f (v: float#): ((_ : value)[@error_message "Custom message"]) = v
55+
^
56+
Error: This expression has type float# but an expression was expected of type
57+
('a : value)
58+
The layout of float# is float64, because
59+
it is the primitive float64 type float#.
60+
But the layout of float# must be a sublayout of value, because
61+
of the annotation on the wildcard _ at line 1, characters 20-31.
62+
Custom message
63+
|}]
64+
65+
let f x =
66+
ignore ((x : (_ : value)[@error_message "Custom message"]));
67+
Float_u.to_float x
68+
[%%expect{|
69+
Line 3, characters 19-20:
70+
3 | Float_u.to_float x
71+
^
72+
Error: This expression has type ('a : value)
73+
but an expression was expected of type float#
74+
The layout of float# is float64, because
75+
it is the primitive float64 type float#.
76+
But the layout of float# must be a sublayout of value, because
77+
of the annotation on the wildcard _ at line 2, characters 15-26.
78+
Custom message
79+
|}]
80+
81+
(* Ltyp_var { name = Some name; layout } case *)
82+
module type a = sig
83+
type ('a : float64) t = 'a
84+
val f : (('a : value)[@error_message "Custom message"]) -> 'a t
85+
end
86+
87+
[%%expect{|
88+
Line 3, characters 61-63:
89+
3 | val f : (('a : value)[@error_message "Custom message"]) -> 'a t
90+
^^
91+
Error: This type ('a : value) should be an instance of type ('b : float64)
92+
The layout of 'a is value, because
93+
of the annotation on the type variable 'a.
94+
Custom message
95+
But the layout of 'a must overlap with float64, because
96+
of the definition of t at line 2, characters 2-28.
97+
|}]
98+
99+
100+
(* Ltyp_alias { aliased_type; name; layout } case *)
101+
102+
(* First call to [layout_of_annotation] in [transl_type_alias] *)
103+
module type a = sig
104+
type t : float64
105+
val f : 'a -> t -> (t as ('a : value)[@error_message "Custom message"])
106+
end
107+
[%%expect{|
108+
Line 3, characters 33-38:
109+
3 | val f : 'a -> t -> (t as ('a : value)[@error_message "Custom message"])
110+
^^^^^
111+
Error: Bad layout annotation:
112+
The layout of t is float64, because
113+
of the definition of t at line 2, characters 2-18.
114+
But the layout of t must be a sublayout of value, because
115+
of the annotation on the type variable 'a.
116+
Custom message
117+
|}]
118+
119+
(* Second call to [layout_of_annotation] in the Not_found case
120+
of [transl_type_alias] *)
121+
module type a = sig
122+
type t : float64
123+
val f : t -> (t as ('a : value)[@error_message "Custom message"])
124+
end
125+
[%%expect{|
126+
Line 3, characters 16-33:
127+
3 | val f : t -> (t as ('a : value)[@error_message "Custom message"])
128+
^^^^^^^^^^^^^^^^^
129+
Error: This alias is bound to type t but is used as an instance of type
130+
('a : value)
131+
The layout of t is float64, because
132+
of the definition of t at line 2, characters 2-18.
133+
But the layout of t must be a sublayout of value, because
134+
of the annotation on the type variable 'a.
135+
Custom message
136+
|}]
137+
138+
(* Third call to [layout_of_annotation] in the None case
139+
of [transl_type_alias] *)
140+
module type a = sig
141+
type t : float64
142+
val f : t -> (t as (_ : value)[@error_message "Custom message"])
143+
end
144+
[%%expect{|
145+
Line 3, characters 26-31:
146+
3 | val f : t -> (t as (_ : value)[@error_message "Custom message"])
147+
^^^^^
148+
Error: Bad layout annotation:
149+
The layout of t/2 is float64, because
150+
of the definition of t at line 2, characters 2-18.
151+
But the layout of t/2 must be a sublayout of value, because
152+
of the annotation on the wildcard _ at line 3, characters 26-31.
153+
Custom message
154+
|}]
155+
156+
(* Currently it's not possible to attach attributes to Ltyp_poly *)

‎ocaml/testsuite/tests/typing-layouts/error_message_attr_w53.compilers.reference

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,12 @@
1+
File "error_message_attr_w53.ml", line 16, characters 43-56:
2+
16 | (int as ('a:value)[@error_message ""][@error_message ""]) (* reject second *)
3+
^^^^^^^^^^^^^
4+
Warning 53 [misplaced-attribute]: the "error_message" attribute cannot appear in this context
5+
File "error_message_attr_w53.ml", line 20, characters 45-58:
6+
20 | let f1 v: ((_ : value)[@error_message ""][@error_message ""]) = v (* reject second *)
7+
^^^^^^^^^^^^^
8+
Warning 53 [misplaced-attribute]: the "error_message" attribute cannot appear in this context
9+
File "error_message_attr_w53.ml", line 21, characters 46-59:
10+
21 | let f2 v: (('a : value)[@error_message ""][@error_message ""]) = v (* reject second *)
11+
^^^^^^^^^^^^^
12+
Warning 53 [misplaced-attribute]: the "error_message" attribute cannot appear in this context

‎ocaml/testsuite/tests/typing-layouts/error_message_attr_w53.ml

Lines changed: 22 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,22 @@
1+
(* TEST
2+
3+
flags = "-w +A-60-70 -extension layouts"
4+
5+
* setup-ocamlc.byte-build-env
6+
** ocamlc.byte
7+
compile_only = "true"
8+
*** check-ocamlc.byte-output
9+
10+
*)
11+
12+
(* CR layouts v1.5: move this to [warnings/w53.ml] when layout annotation is generally avaliable
13+
without the layouts extension flag. *)
14+
module type TestErrorMessageSig = sig
15+
val f : int ->
16+
(int as ('a:value)[@error_message ""][@error_message ""]) (* reject second *)
17+
end
18+
19+
module TestErrorMessageStruct = struct
20+
let f1 v: ((_ : value)[@error_message ""][@error_message ""]) = v (* reject second *)
21+
let f2 v: (('a : value)[@error_message ""][@error_message ""]) = v (* reject second *)
22+
end

‎ocaml/testsuite/tests/warnings/w53.compilers.reference

Lines changed: 48 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -582,3 +582,51 @@ File "w53.ml", line 356, characters 17-22:
582582
356 | let f2 = fun [@boxed] (type a) (x : a) -> x (* rejected *)
583583
^^^^^
584584
Warning 53 [misplaced-attribute]: the "boxed" attribute cannot appear in this context
585+
File "w53.ml", line 360, characters 21-34:
586+
360 | type 'a t1 = 'a [@@error_message ""] (* rejected *)
587+
^^^^^^^^^^^^^
588+
Warning 53 [misplaced-attribute]: the "error_message" attribute cannot appear in this context
589+
File "w53.ml", line 361, characters 19-32:
590+
361 | type s1 = Foo1 [@error_message ""] (* rejected *)
591+
^^^^^^^^^^^^^
592+
Warning 53 [misplaced-attribute]: the "error_message" attribute cannot appear in this context
593+
File "w53.ml", line 362, characters 17-30:
594+
362 | val x : int [@@error_message ""] (* rejected *)
595+
^^^^^^^^^^^^^
596+
Warning 53 [misplaced-attribute]: the "error_message" attribute cannot appear in this context
597+
File "w53.ml", line 364, characters 22-35:
598+
364 | external y : (int [@error_message ""]) -> (int [@error_message ""]) = (* rejected *)
599+
^^^^^^^^^^^^^
600+
Warning 53 [misplaced-attribute]: the "error_message" attribute cannot appear in this context
601+
File "w53.ml", line 364, characters 51-64:
602+
364 | external y : (int [@error_message ""]) -> (int [@error_message ""]) = (* rejected *)
603+
^^^^^^^^^^^^^
604+
Warning 53 [misplaced-attribute]: the "error_message" attribute cannot appear in this context
605+
File "w53.ml", line 366, characters 39-52:
606+
366 | external z : int -> int = "x" "y" [@@error_message ""] (* rejected *)
607+
^^^^^^^^^^^^^
608+
Warning 53 [misplaced-attribute]: the "error_message" attribute cannot appear in this context
609+
File "w53.ml", line 370, characters 21-34:
610+
370 | type 'a t1 = 'a [@@error_message ""] (* rejected *)
611+
^^^^^^^^^^^^^
612+
Warning 53 [misplaced-attribute]: the "error_message" attribute cannot appear in this context
613+
File "w53.ml", line 371, characters 19-32:
614+
371 | type s1 = Foo1 [@error_message ""] (* rejected *)
615+
^^^^^^^^^^^^^
616+
Warning 53 [misplaced-attribute]: the "error_message" attribute cannot appear in this context
617+
File "w53.ml", line 372, characters 22-35:
618+
372 | let x : int = 42 [@@error_message ""] (* rejected *)
619+
^^^^^^^^^^^^^
620+
Warning 53 [misplaced-attribute]: the "error_message" attribute cannot appear in this context
621+
File "w53.ml", line 374, characters 22-35:
622+
374 | external y : (int [@error_message ""]) -> (int [@error_message ""]) = (* rejected *)
623+
^^^^^^^^^^^^^
624+
Warning 53 [misplaced-attribute]: the "error_message" attribute cannot appear in this context
625+
File "w53.ml", line 374, characters 51-64:
626+
374 | external y : (int [@error_message ""]) -> (int [@error_message ""]) = (* rejected *)
627+
^^^^^^^^^^^^^
628+
Warning 53 [misplaced-attribute]: the "error_message" attribute cannot appear in this context
629+
File "w53.ml", line 376, characters 39-52:
630+
376 | external z : int -> int = "x" "y" [@@error_message ""] (* rejected *)
631+
^^^^^^^^^^^^^
632+
Warning 53 [misplaced-attribute]: the "error_message" attribute cannot appear in this context

‎ocaml/testsuite/tests/warnings/w53.ml

Lines changed: 20 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -355,3 +355,23 @@ module TestNewtypeAttr = struct
355355

356356
let f2 = fun [@boxed] (type a) (x : a) -> x (* rejected *)
357357
end
358+
359+
module type TestErrorMessageSig = sig
360+
type 'a t1 = 'a [@@error_message ""] (* rejected *)
361+
type s1 = Foo1 [@error_message ""] (* rejected *)
362+
val x : int [@@error_message ""] (* rejected *)
363+
364+
external y : (int [@error_message ""]) -> (int [@error_message ""]) = (* rejected *)
365+
"x" "y"
366+
external z : int -> int = "x" "y" [@@error_message ""] (* rejected *)
367+
end
368+
369+
module TestErrorMessageStruct = struct
370+
type 'a t1 = 'a [@@error_message ""] (* rejected *)
371+
type s1 = Foo1 [@error_message ""] (* rejected *)
372+
let x : int = 42 [@@error_message ""] (* rejected *)
373+
374+
external y : (int [@error_message ""]) -> (int [@error_message ""]) = (* rejected *)
375+
"x" "y"
376+
external z : int -> int = "x" "y" [@@error_message ""] (* rejected *)
377+
end

‎ocaml/testsuite/tests/warnings/w53_marshalled.compilers.reference

Lines changed: 48 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -578,3 +578,51 @@ File "w53.ml", line 356, characters 17-22:
578578
356 | let f2 = fun [@boxed] (type a) (x : a) -> x (* rejected *)
579579
^^^^^
580580
Warning 53 [misplaced-attribute]: the "boxed" attribute cannot appear in this context
581+
File "w53.ml", line 360, characters 21-34:
582+
360 | type 'a t1 = 'a [@@error_message ""] (* rejected *)
583+
^^^^^^^^^^^^^
584+
Warning 53 [misplaced-attribute]: the "error_message" attribute cannot appear in this context
585+
File "w53.ml", line 361, characters 19-32:
586+
361 | type s1 = Foo1 [@error_message ""] (* rejected *)
587+
^^^^^^^^^^^^^
588+
Warning 53 [misplaced-attribute]: the "error_message" attribute cannot appear in this context
589+
File "w53.ml", line 362, characters 17-30:
590+
362 | val x : int [@@error_message ""] (* rejected *)
591+
^^^^^^^^^^^^^
592+
Warning 53 [misplaced-attribute]: the "error_message" attribute cannot appear in this context
593+
File "w53.ml", line 364, characters 22-35:
594+
364 | external y : (int [@error_message ""]) -> (int [@error_message ""]) = (* rejected *)
595+
^^^^^^^^^^^^^
596+
Warning 53 [misplaced-attribute]: the "error_message" attribute cannot appear in this context
597+
File "w53.ml", line 364, characters 51-64:
598+
364 | external y : (int [@error_message ""]) -> (int [@error_message ""]) = (* rejected *)
599+
^^^^^^^^^^^^^
600+
Warning 53 [misplaced-attribute]: the "error_message" attribute cannot appear in this context
601+
File "w53.ml", line 366, characters 39-52:
602+
366 | external z : int -> int = "x" "y" [@@error_message ""] (* rejected *)
603+
^^^^^^^^^^^^^
604+
Warning 53 [misplaced-attribute]: the "error_message" attribute cannot appear in this context
605+
File "w53.ml", line 370, characters 21-34:
606+
370 | type 'a t1 = 'a [@@error_message ""] (* rejected *)
607+
^^^^^^^^^^^^^
608+
Warning 53 [misplaced-attribute]: the "error_message" attribute cannot appear in this context
609+
File "w53.ml", line 371, characters 19-32:
610+
371 | type s1 = Foo1 [@error_message ""] (* rejected *)
611+
^^^^^^^^^^^^^
612+
Warning 53 [misplaced-attribute]: the "error_message" attribute cannot appear in this context
613+
File "w53.ml", line 372, characters 22-35:
614+
372 | let x : int = 42 [@@error_message ""] (* rejected *)
615+
^^^^^^^^^^^^^
616+
Warning 53 [misplaced-attribute]: the "error_message" attribute cannot appear in this context
617+
File "w53.ml", line 374, characters 22-35:
618+
374 | external y : (int [@error_message ""]) -> (int [@error_message ""]) = (* rejected *)
619+
^^^^^^^^^^^^^
620+
Warning 53 [misplaced-attribute]: the "error_message" attribute cannot appear in this context
621+
File "w53.ml", line 374, characters 51-64:
622+
374 | external y : (int [@error_message ""]) -> (int [@error_message ""]) = (* rejected *)
623+
^^^^^^^^^^^^^
624+
Warning 53 [misplaced-attribute]: the "error_message" attribute cannot appear in this context
625+
File "w53.ml", line 376, characters 39-52:
626+
376 | external z : int -> int = "x" "y" [@@error_message ""] (* rejected *)
627+
^^^^^^^^^^^^^
628+
Warning 53 [misplaced-attribute]: the "error_message" attribute cannot appear in this context

0 commit comments

Comments
 (0)