Skip to content

Commit 6b748bc

Browse files
EnoumyEnoumy
authored
[%call_pos] application via an optional argument results in an error (#2497)
* Added test case showing unhandled optional application * Removed warning when [%call_pos] is applied optionally * Fixed! Cleanup still pending - unsure if my approach is sound... * Clearer object system test * Add test case on object system that is still failing * preserve guard order * Fixed object system application * Deduplicated optional application function * Turned applying a [%call_pos] argument into an error after discussion. * Address comments during review - Nicer error message - Nicer formatting that does not exceed 80 characters * Small refactor lowering line lengths more
1 parent 5d53384 commit 6b748bc

File tree

5 files changed

+155
-7
lines changed

5 files changed

+155
-7
lines changed

‎ocaml/testsuite/tests/typing-implicit-source-positions/application_via_option.ml

+119
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,119 @@
1+
(* TEST_BELOW
2+
Fille
3+
*)
4+
5+
let f = fun ~(call_pos:[%call_pos]) () -> call_pos
6+
[%%expect {|
7+
val f : call_pos:[%call_pos] -> unit -> lexing_position = <fun>
8+
|}]
9+
10+
let _ = f ?call_pos:None ();
11+
[%%expect {|
12+
Line 1, characters 20-24:
13+
1 | let _ = f ?call_pos:None ();
14+
^^^^
15+
Error: the argument labeled 'call_pos' is a [%call_pos] argument, filled in
16+
automatically if ommitted. It cannot be passed with '?'.
17+
|}]
18+
19+
let _ =
20+
let pos = f () in
21+
f ?call_pos:(Some pos) ();
22+
[%%expect {|
23+
Line 3, characters 14-24:
24+
3 | f ?call_pos:(Some pos) ();
25+
^^^^^^^^^^
26+
Error: the argument labeled 'call_pos' is a [%call_pos] argument, filled in
27+
automatically if ommitted. It cannot be passed with '?'.
28+
|}]
29+
30+
let ( >>| ) ~(call_pos : [%call_pos]) a b = a + b, call_pos ;;
31+
[%%expect {|
32+
val ( >>| ) : call_pos:[%call_pos] -> int -> int -> int * lexing_position =
33+
<fun>
34+
|}]
35+
36+
let _ = ( >>| ) ?call_pos:None 1 2 ;;
37+
[%%expect {|
38+
Line 1, characters 27-31:
39+
1 | let _ = ( >>| ) ?call_pos:None 1 2 ;;
40+
^^^^
41+
Error: the argument labeled 'call_pos' is a [%call_pos] argument, filled in
42+
automatically if ommitted. It cannot be passed with '?'.
43+
|}]
44+
45+
let _ =
46+
let pos = f () in
47+
( >>| ) ?call_pos:(Some pos) 1 2
48+
;;
49+
[%%expect {|
50+
Line 3, characters 20-30:
51+
3 | ( >>| ) ?call_pos:(Some pos) 1 2
52+
^^^^^^^^^^
53+
Error: the argument labeled 'call_pos' is a [%call_pos] argument, filled in
54+
automatically if ommitted. It cannot be passed with '?'.
55+
|}]
56+
57+
class c ~(call_pos : [%call_pos]) () = object
58+
method call_pos = call_pos
59+
end
60+
[%%expect {|
61+
class c :
62+
call_pos:[%call_pos] ->
63+
unit -> object method call_pos : lexing_position end
64+
|}]
65+
66+
let _ = (new c ?call_pos:None ())#call_pos;;
67+
[%%expect {|
68+
Line 1, characters 25-29:
69+
1 | let _ = (new c ?call_pos:None ())#call_pos;;
70+
^^^^
71+
Error: the argument labeled 'call_pos' is a [%call_pos] argument, filled in
72+
automatically if ommitted. It cannot be passed with '?'.
73+
|}]
74+
75+
let _ =
76+
let pos = f () in
77+
(new c ?call_pos:(Some pos) ())#call_pos;;
78+
[%%expect {|
79+
Line 3, characters 19-29:
80+
3 | (new c ?call_pos:(Some pos) ())#call_pos;;
81+
^^^^^^^^^^
82+
Error: the argument labeled 'call_pos' is a [%call_pos] argument, filled in
83+
automatically if ommitted. It cannot be passed with '?'.
84+
|}]
85+
86+
class parent ~(call_pos : [%call_pos]) () = object
87+
method pos = call_pos
88+
end
89+
[%%expect {|
90+
class parent :
91+
call_pos:[%call_pos] -> unit -> object method pos : lexing_position end
92+
|}]
93+
94+
let _ = (object
95+
inherit parent ?call_pos:None ()
96+
end)#pos;;
97+
[%%expect {|
98+
Line 2, characters 27-31:
99+
2 | inherit parent ?call_pos:None ()
100+
^^^^
101+
Error: the argument labeled 'call_pos' is a [%call_pos] argument, filled in
102+
automatically if ommitted. It cannot be passed with '?'.
103+
|}]
104+
105+
let o = (object
106+
inherit parent ?call_pos:(Some (f ())) ()
107+
end)#pos
108+
[%%expect {|
109+
Line 2, characters 27-40:
110+
2 | inherit parent ?call_pos:(Some (f ())) ()
111+
^^^^^^^^^^^^^
112+
Error: the argument labeled 'call_pos' is a [%call_pos] argument, filled in
113+
automatically if ommitted. It cannot be passed with '?'.
114+
|}]
115+
116+
117+
(* TEST
118+
expect;
119+
*)

‎ocaml/typing/typeclass.ml

+16-4
Original file line numberDiff line numberDiff line change
@@ -110,6 +110,7 @@ type error =
110110
| Polymorphic_class_parameter
111111
| Non_value_binding of string * Jkind.Violation.t
112112
| Non_value_let_binding of string * Jkind.sort
113+
| Nonoptional_call_pos_label of string
113114

114115
exception Error of Location.t * Env.t * error
115116
exception Error_forward of Location.error
@@ -1362,10 +1363,17 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl =
13621363
end else
13631364
match Btype.extract_label name sargs with
13641365
| Some (l', sarg, _, remaining_sargs) ->
1365-
if not optional && Btype.is_optional l' then
1366-
Location.prerr_warning sarg.pexp_loc
1367-
(Warnings.Nonoptional_label
1368-
(Printtyp.string_of_label l));
1366+
if not optional && Btype.is_optional l' then (
1367+
let label = Printtyp.string_of_label l in
1368+
if Btype.is_position l then
1369+
raise
1370+
(Error
1371+
( sarg.pexp_loc
1372+
, val_env
1373+
, Nonoptional_call_pos_label label))
1374+
else
1375+
Location.prerr_warning sarg.pexp_loc
1376+
(Warnings.Nonoptional_label label));
13691377
remaining_sargs, use_arg sarg l'
13701378
| None ->
13711379
let is_erased () = List.mem_assoc Nolabel sargs in
@@ -2332,6 +2340,10 @@ let report_error env ppf = function
23322340
"@[The types of variables bound by a 'let' in a class function@ \
23332341
must have layout value. Instead, %s's type has layout %a.@]"
23342342
nm Jkind.Sort.format sort
2343+
| Nonoptional_call_pos_label label ->
2344+
fprintf ppf
2345+
"@[the argument labeled '%s' is a [%%call_pos] argument, filled in @ \
2346+
automatically if ommitted. It cannot be passed with '?'.@]" label
23352347

23362348
let report_error env ppf err =
23372349
Printtyp.wrap_printing_env ~error:true

‎ocaml/typing/typeclass.mli

+1
Original file line numberDiff line numberDiff line change
@@ -128,6 +128,7 @@ type error =
128128
| Polymorphic_class_parameter
129129
| Non_value_binding of string * Jkind.Violation.t
130130
| Non_value_let_binding of string * Jkind.sort
131+
| Nonoptional_call_pos_label of string
131132

132133
exception Error of Location.t * Env.t * error
133134
exception Error_forward of Location.error

‎ocaml/typing/typecore.ml

+18-3
Original file line numberDiff line numberDiff line change
@@ -230,6 +230,7 @@ type error =
230230
| Function_type_not_rep of type_expr * Jkind.Violation.t
231231
| Modes_on_pattern
232232
| Invalid_label_for_src_pos of arg_label
233+
| Nonoptional_call_pos_label of string
233234

234235
exception Error of Location.t * Env.t * error
235236
exception Error_forward of Location.error
@@ -3637,9 +3638,19 @@ let collect_apply_args env funct ignore_labels ty_fun ty_fun0 mode_fun sargs ret
36373638
may_warn sarg.pexp_loc
36383639
(Warnings.Not_principal "commuting this argument")
36393640
end;
3640-
if not optional && is_optional l' then
3641-
Location.prerr_warning sarg.pexp_loc
3642-
(Warnings.Nonoptional_label (Printtyp.string_of_label l));
3641+
if not optional && is_optional l' then (
3642+
let label = Printtyp.string_of_label l in
3643+
if is_position l
3644+
then
3645+
raise
3646+
(Error
3647+
( sarg.pexp_loc
3648+
, env
3649+
, Nonoptional_call_pos_label label))
3650+
else
3651+
Location.prerr_warning
3652+
sarg.pexp_loc
3653+
(Warnings.Nonoptional_label label));
36433654
remaining_sargs, use_arg ~commuted sarg l'
36443655
| None ->
36453656
sargs,
@@ -10204,6 +10215,10 @@ let report_error ~loc env = function
1020410215
| Nolabel -> "unlabelled"
1020510216
| Optional _ -> "optional"
1020610217
| Labelled _ | Position _ -> assert false )
10218+
| Nonoptional_call_pos_label label ->
10219+
Location.errorf ~loc
10220+
"@[the argument labeled '%s' is a [%%call_pos] argument, filled in @ \
10221+
automatically if ommitted. It cannot be passed with '?'.@]" label
1020710222
1020810223
let report_error ~loc env err =
1020910224
Printtyp.wrap_printing_env ~error:true env

‎ocaml/typing/typecore.mli

+1
Original file line numberDiff line numberDiff line change
@@ -295,6 +295,7 @@ type error =
295295
| Function_type_not_rep of type_expr * Jkind.Violation.t
296296
| Modes_on_pattern
297297
| Invalid_label_for_src_pos of arg_label
298+
| Nonoptional_call_pos_label of string
298299

299300
exception Error of Location.t * Env.t * error
300301
exception Error_forward of Location.error

0 commit comments

Comments
 (0)