Skip to content

Commit 39e2b1e

Browse files
riaqnriaqn
authored
flambda-backend: Mode error messages should use the solver error (#2383)
* better mode error messages * address comments
1 parent b6e3c58 commit 39e2b1e

File tree

7 files changed

+65
-52
lines changed

7 files changed

+65
-52
lines changed

‎testsuite/tests/formatting/test_locations.dlocations.ocamlc.reference

Lines changed: 9 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -88,14 +88,14 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
8888
<def>
8989
pattern (test_locations.ml[17,534+8]..test_locations.ml[17,534+11])
9090
Tpat_var "fib"
91-
value_mode Global,Many,Shared
91+
value_mode global,many,shared
9292
expression (test_locations.ml[17,534+14]..test_locations.ml[19,572+34])
9393
Texp_function
9494
region true
95-
alloc_mode Global,Many,Shared
95+
alloc_mode global,many,shared
9696
[]
9797
Tfunction_cases (test_locations.ml[17,534+14]..test_locations.ml[19,572+34])
98-
alloc_mode Global,Many,Shared
98+
alloc_mode global,many,shared
9999
value
100100
[
101101
<case>
@@ -110,11 +110,11 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
110110
<case>
111111
pattern (test_locations.ml[19,572+4]..test_locations.ml[19,572+5])
112112
Tpat_var "n"
113-
value_mode Global,Many,Unique
113+
value_mode global,many,unique
114114
expression (test_locations.ml[19,572+9]..test_locations.ml[19,572+34])
115115
Texp_apply
116116
apply_mode Tail
117-
locality_mode Global
117+
locality_mode global
118118
expression (test_locations.ml[19,572+21]..test_locations.ml[19,572+22])
119119
Texp_ident "Stdlib!.+"
120120
[
@@ -123,7 +123,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
123123
expression (test_locations.ml[19,572+9]..test_locations.ml[19,572+20])
124124
Texp_apply
125125
apply_mode Default
126-
locality_mode Global
126+
locality_mode global
127127
expression (test_locations.ml[19,572+9]..test_locations.ml[19,572+12])
128128
Texp_ident "fib"
129129
[
@@ -132,7 +132,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
132132
expression (test_locations.ml[19,572+13]..test_locations.ml[19,572+20])
133133
Texp_apply
134134
apply_mode Default
135-
locality_mode Global
135+
locality_mode global
136136
expression (test_locations.ml[19,572+16]..test_locations.ml[19,572+17])
137137
Texp_ident "Stdlib!.-"
138138
[
@@ -151,7 +151,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
151151
expression (test_locations.ml[19,572+23]..test_locations.ml[19,572+34])
152152
Texp_apply
153153
apply_mode Default
154-
locality_mode Global
154+
locality_mode global
155155
expression (test_locations.ml[19,572+23]..test_locations.ml[19,572+26])
156156
Texp_ident "fib"
157157
[
@@ -160,7 +160,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
160160
expression (test_locations.ml[19,572+27]..test_locations.ml[19,572+34])
161161
Texp_apply
162162
apply_mode Default
163-
locality_mode Global
163+
locality_mode global
164164
expression (test_locations.ml[19,572+30]..test_locations.ml[19,572+31])
165165
Texp_ident "Stdlib!.-"
166166
[

‎testsuite/tests/formatting/test_locations.dno-locations.ocamlc.reference

Lines changed: 9 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -88,14 +88,14 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
8888
<def>
8989
pattern
9090
Tpat_var "fib"
91-
value_mode Global,Many,Shared
91+
value_mode global,many,shared
9292
expression
9393
Texp_function
9494
region true
95-
alloc_mode Global,Many,Shared
95+
alloc_mode global,many,shared
9696
[]
9797
Tfunction_cases
98-
alloc_mode Global,Many,Shared
98+
alloc_mode global,many,shared
9999
value
100100
[
101101
<case>
@@ -110,11 +110,11 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
110110
<case>
111111
pattern
112112
Tpat_var "n"
113-
value_mode Global,Many,Unique
113+
value_mode global,many,unique
114114
expression
115115
Texp_apply
116116
apply_mode Tail
117-
locality_mode Global
117+
locality_mode global
118118
expression
119119
Texp_ident "Stdlib!.+"
120120
[
@@ -123,7 +123,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
123123
expression
124124
Texp_apply
125125
apply_mode Default
126-
locality_mode Global
126+
locality_mode global
127127
expression
128128
Texp_ident "fib"
129129
[
@@ -132,7 +132,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
132132
expression
133133
Texp_apply
134134
apply_mode Default
135-
locality_mode Global
135+
locality_mode global
136136
expression
137137
Texp_ident "Stdlib!.-"
138138
[
@@ -151,7 +151,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
151151
expression
152152
Texp_apply
153153
apply_mode Default
154-
locality_mode Global
154+
locality_mode global
155155
expression
156156
Texp_ident "fib"
157157
[
@@ -160,7 +160,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
160160
expression
161161
Texp_apply
162162
apply_mode Default
163-
locality_mode Global
163+
locality_mode global
164164
expression
165165
Texp_ident "Stdlib!.-"
166166
[

‎testsuite/tests/typing-local/local.ml

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1478,8 +1478,8 @@ let foo : 'a -> unit = fun (local_ x) -> ()
14781478
Line 1, characters 23-43:
14791479
1 | let foo : 'a -> unit = fun (local_ x) -> ()
14801480
^^^^^^^^^^^^^^^^^^^^
1481-
Error: This function has a local parameter, but was expected to have type:
1482-
'a -> unit
1481+
Error: This function takes a local parameter,
1482+
but was expected to take a global parameter.
14831483
|}]
14841484
14851485
(* Return mode must be greater than the type *)

‎typing/mode.ml

Lines changed: 11 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -23,6 +23,8 @@ type nonrec allowed = allowed
2323

2424
type nonrec disallowed = disallowed
2525

26+
type nonrec equate_step = equate_step
27+
2628
module Axis = struct
2729
type t =
2830
[ `Locality
@@ -149,8 +151,8 @@ module Lattices = struct
149151
| Local, Local -> Local
150152

151153
let print ppf = function
152-
| Global -> Format.fprintf ppf "Global"
153-
| Local -> Format.fprintf ppf "Local"
154+
| Global -> Format.fprintf ppf "global"
155+
| Local -> Format.fprintf ppf "local"
154156
end)
155157

156158
let _is_areality = ()
@@ -190,9 +192,9 @@ module Lattices = struct
190192
| Regional, Regional -> true
191193

192194
let print ppf = function
193-
| Global -> Format.fprintf ppf "Global"
194-
| Regional -> Format.fprintf ppf "Regional"
195-
| Local -> Format.fprintf ppf "Local"
195+
| Global -> Format.fprintf ppf "global"
196+
| Regional -> Format.fprintf ppf "regional"
197+
| Local -> Format.fprintf ppf "local"
196198
end)
197199

198200
let _is_areality = ()
@@ -228,8 +230,8 @@ module Lattices = struct
228230
| Shared, Shared -> Shared
229231

230232
let print ppf = function
231-
| Shared -> Format.fprintf ppf "Shared"
232-
| Unique -> Format.fprintf ppf "Unique"
233+
| Shared -> Format.fprintf ppf "shared"
234+
| Unique -> Format.fprintf ppf "unique"
233235
end)
234236
end
235237

@@ -259,8 +261,8 @@ module Lattices = struct
259261
match a, b with Many, _ | _, Many -> Many | Once, Once -> Once
260262

261263
let print ppf = function
262-
| Once -> Format.fprintf ppf "Once"
263-
| Many -> Format.fprintf ppf "Many"
264+
| Once -> Format.fprintf ppf "once"
265+
| Many -> Format.fprintf ppf "many"
264266
end)
265267
end
266268

‎typing/mode_intf.mli

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -127,6 +127,8 @@ module type S = sig
127127

128128
type nonrec disallowed = disallowed
129129

130+
type nonrec equate_step = equate_step
131+
130132
type ('a, 'b) monadic_comonadic =
131133
{ monadic : 'a;
132134
comonadic : 'b

‎typing/typecore.ml

Lines changed: 31 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -217,7 +217,7 @@ type error =
217217
Env.closure_context option *
218218
Env.shared_context option
219219
| Local_application_complete of Asttypes.arg_label * [`Prefix|`Single_arg|`Entire_apply]
220-
| Param_mode_mismatch of type_expr * Alloc.equate_error
220+
| Param_mode_mismatch of Alloc.equate_error
221221
| Uncurried_function_escapes of Alloc.error
222222
| Local_return_annotation_mismatch of Location.t
223223
| Function_returns_local
@@ -847,9 +847,9 @@ let mode_annots_from_pat_attrs pat =
847847
in
848848
Typemode.transl_mode_annots modes, {pat with ppat_attributes}
849849

850-
let apply_mode_annots ~loc ~env ~ty_expected (m : Alloc.Const.Option.t) mode =
850+
let apply_mode_annots ~loc ~env (m : Alloc.Const.Option.t) mode =
851851
let error axis =
852-
raise (Error(loc, env, Param_mode_mismatch (ty_expected, axis)))
852+
raise (Error(loc, env, Param_mode_mismatch axis))
853853
in
854854
Option.iter (fun locality ->
855855
match Locality.equate (Locality.of_const locality) (Alloc.locality mode) with
@@ -4108,7 +4108,7 @@ let type_approx_fun_one_param
41084108
in
41094109
Option.iter
41104110
(fun mode_annots ->
4111-
apply_mode_annots ~loc ~env ~ty_expected mode_annots arg_mode)
4111+
apply_mode_annots ~loc ~env mode_annots arg_mode)
41124112
mode_annots;
41134113
if has_poly then begin
41144114
match spato with
@@ -4781,7 +4781,7 @@ let split_function_ty
47814781
generalize_structure ty_arg;
47824782
generalize_structure ty_ret)
47834783
in
4784-
apply_mode_annots ~loc:loc_fun ~env ~ty_expected mode_annots arg_mode;
4784+
apply_mode_annots ~loc:loc_fun ~env mode_annots arg_mode;
47854785
if not has_poly && not (tpoly_is_mono ty_arg) && !Clflags.principal
47864786
&& get_level ty_arg < Btype.generic_level then begin
47874787
let snap = Btype.snapshot () in
@@ -9975,11 +9975,13 @@ let report_error ~loc env = function
99759975
| `Regionality _ ->
99769976
escaping_hint fail_reason submode_reason closure_context
99779977
in
9978-
Location.errorf ~loc ~sub begin
9978+
Location.errorf ~loc ~sub "%t" begin
99799979
match fail_reason with
9980-
| `Regionality _ -> "This value escapes its region"
9981-
| `Uniqueness _ -> "Found a shared value where a unique value was expected"
9982-
| `Linearity _ -> "Found a once value where a many value was expected"
9980+
| `Regionality _ -> Format.dprintf "This value escapes its region"
9981+
| `Uniqueness {left; right} -> Format.dprintf "Found a %a value where a %a value was expected"
9982+
Uniqueness.Const.print left Uniqueness.Const.print right
9983+
| `Linearity {left; right} -> Format.dprintf "Found a %a value where a %a value was expected"
9984+
Linearity.Const.print left Linearity.Const.print right
99839985
end
99849986
| Local_application_complete (lbl, loc_kind) ->
99859987
let sub =
@@ -10004,25 +10006,32 @@ let report_error ~loc env = function
1000410006
Location.errorf ~loc ~sub
1000510007
"@[This application is complete, but surplus arguments were provided afterwards.@ \
1000610008
When passing or calling a local value, extra arguments are passed in a separate application.@]"
10007-
| Param_mode_mismatch (ty, (_, mkind)) ->
10008-
let mkind =
10009-
match mkind with
10010-
| `Locality _ -> "local"
10011-
| `Uniqueness _ -> "unique"
10012-
| `Linearity _ -> "once"
10013-
in
10014-
Location.errorf ~loc
10015-
"@[This function has a %s parameter, but was expected to have type:@ %a@]"
10016-
mkind Printtyp.type_expr ty
10009+
| Param_mode_mismatch (s, mkind) ->
10010+
let print_error f (step, {Solver.left; Solver.right}) =
10011+
let actual, expected =
10012+
match (step : equate_step) with
10013+
| Left_le_right -> left, right
10014+
| Right_le_left -> right, left
10015+
in
10016+
Location.errorf ~loc
10017+
"@[This function takes a %a parameter,@ \
10018+
but was expected to take a %a parameter.@]"
10019+
f actual f expected
10020+
in begin
10021+
match mkind with
10022+
| `Locality e -> print_error Locality.Const.print (s, e)
10023+
| `Uniqueness e -> print_error Uniqueness.Const.print (s, e)
10024+
| `Linearity e -> print_error Linearity.Const.print (s, e)
10025+
end
1001710026
| Uncurried_function_escapes e -> begin
1001810027
match e with
1001910028
| `Locality _ ->
1002010029
Location.errorf ~loc "This function or one of its parameters escape their region @ \
1002110030
when it is partially applied."
1002210031
| `Uniqueness _ -> assert false
10023-
| `Linearity _ ->
10024-
Location.errorf ~loc "This function when partially applied returns a once value,@ \
10025-
but expected to be many."
10032+
| `Linearity {left; right} ->
10033+
Location.errorf ~loc "This function when partially applied returns a %a value,@ \
10034+
but expected to be %a." Linearity.Const.print left Linearity.Const.print right
1002610035
end
1002710036
| Local_return_annotation_mismatch _ ->
1002810037
Location.errorf ~loc

‎typing/typecore.mli

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -282,7 +282,7 @@ type error =
282282
Mode.Value.error * submode_reason *
283283
Env.closure_context option * Env.shared_context option
284284
| Local_application_complete of Asttypes.arg_label * [`Prefix|`Single_arg|`Entire_apply]
285-
| Param_mode_mismatch of type_expr * Mode.Alloc.equate_error
285+
| Param_mode_mismatch of Mode.Alloc.equate_error
286286
| Uncurried_function_escapes of Mode.Alloc.error
287287
| Local_return_annotation_mismatch of Location.t
288288
| Function_returns_local

0 commit comments

Comments
 (0)