Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Mode error messages should use the solver error #2383

Merged
merged 2 commits into from
Mar 20, 2024
Merged

Mode error messages should use the solver error #2383

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
b08fab7
better mode error messages
riaqn Mar 20, 2024
6f0d9dd
address comments
riaqn Mar 20, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
18 changes: 9 additions & 9 deletions ocaml/testsuite/tests/formatting/test_locations.dlocations.ocamlc.reference
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -88,14 +88,14 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
<def>
pattern (test_locations.ml[17,534+8]..test_locations.ml[17,534+11])
Tpat_var "fib"
value_mode Global,Many,Shared
value_mode global,many,shared
expression (test_locations.ml[17,534+14]..test_locations.ml[19,572+34])
Texp_function
region true
alloc_mode Global,Many,Shared
alloc_mode global,many,shared
[]
Tfunction_cases (test_locations.ml[17,534+14]..test_locations.ml[19,572+34])
alloc_mode Global,Many,Shared
alloc_mode global,many,shared
value
[
<case>
Expand All @@ -110,11 +110,11 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
<case>
pattern (test_locations.ml[19,572+4]..test_locations.ml[19,572+5])
Tpat_var "n"
value_mode Global,Many,Unique
value_mode global,many,unique
expression (test_locations.ml[19,572+9]..test_locations.ml[19,572+34])
Texp_apply
apply_mode Tail
locality_mode Global
locality_mode global
expression (test_locations.ml[19,572+21]..test_locations.ml[19,572+22])
Texp_ident "Stdlib!.+"
[
Expand All @@ -123,7 +123,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
expression (test_locations.ml[19,572+9]..test_locations.ml[19,572+20])
Texp_apply
apply_mode Default
locality_mode Global
locality_mode global
expression (test_locations.ml[19,572+9]..test_locations.ml[19,572+12])
Texp_ident "fib"
[
Expand All @@ -132,7 +132,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
expression (test_locations.ml[19,572+13]..test_locations.ml[19,572+20])
Texp_apply
apply_mode Default
locality_mode Global
locality_mode global
expression (test_locations.ml[19,572+16]..test_locations.ml[19,572+17])
Texp_ident "Stdlib!.-"
[
Expand All @@ -151,7 +151,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
expression (test_locations.ml[19,572+23]..test_locations.ml[19,572+34])
Texp_apply
apply_mode Default
locality_mode Global
locality_mode global
expression (test_locations.ml[19,572+23]..test_locations.ml[19,572+26])
Texp_ident "fib"
[
Expand All @@ -160,7 +160,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
expression (test_locations.ml[19,572+27]..test_locations.ml[19,572+34])
Texp_apply
apply_mode Default
locality_mode Global
locality_mode global
expression (test_locations.ml[19,572+30]..test_locations.ml[19,572+31])
Texp_ident "Stdlib!.-"
[
Expand Down
18 changes: 9 additions & 9 deletions ocaml/testsuite/tests/formatting/test_locations.dno-locations.ocamlc.reference
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -88,14 +88,14 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
<def>
pattern
Tpat_var "fib"
value_mode Global,Many,Shared
value_mode global,many,shared
expression
Texp_function
region true
alloc_mode Global,Many,Shared
alloc_mode global,many,shared
[]
Tfunction_cases
alloc_mode Global,Many,Shared
alloc_mode global,many,shared
value
[
<case>
Expand All @@ -110,11 +110,11 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
<case>
pattern
Tpat_var "n"
value_mode Global,Many,Unique
value_mode global,many,unique
expression
Texp_apply
apply_mode Tail
locality_mode Global
locality_mode global
expression
Texp_ident "Stdlib!.+"
[
Expand All @@ -123,7 +123,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
expression
Texp_apply
apply_mode Default
locality_mode Global
locality_mode global
expression
Texp_ident "fib"
[
Expand All @@ -132,7 +132,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
expression
Texp_apply
apply_mode Default
locality_mode Global
locality_mode global
expression
Texp_ident "Stdlib!.-"
[
Expand All @@ -151,7 +151,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
expression
Texp_apply
apply_mode Default
locality_mode Global
locality_mode global
expression
Texp_ident "fib"
[
Expand All @@ -160,7 +160,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
expression
Texp_apply
apply_mode Default
locality_mode Global
locality_mode global
expression
Texp_ident "Stdlib!.-"
[
Expand Down
4 changes: 2 additions & 2 deletions ocaml/testsuite/tests/typing-local/local.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -1478,8 +1478,8 @@ let foo : 'a -> unit = fun (local_ x) -> ()
Line 1, characters 23-43:
1 | let foo : 'a -> unit = fun (local_ x) -> ()
^^^^^^^^^^^^^^^^^^^^
Error: This function has a local parameter, but was expected to have type:
'a -> unit
Error: This function takes a local parameter,
but was expected to take a global parameter.
|}]

(* Return mode must be greater than the type *)
Expand Down
20 changes: 11 additions & 9 deletions ocaml/typing/mode.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -23,6 +23,8 @@ type nonrec allowed = allowed

type nonrec disallowed = disallowed

type nonrec equate_step = equate_step

module Axis = struct
type t =
[ `Locality
Expand Down Expand Up @@ -149,8 +151,8 @@ module Lattices = struct
| Local, Local -> Local

let print ppf = function
| Global -> Format.fprintf ppf "Global"
| Local -> Format.fprintf ppf "Local"
| Global -> Format.fprintf ppf "global"
| Local -> Format.fprintf ppf "local"
end)

let _is_areality = ()
Expand Down Expand Up @@ -190,9 +192,9 @@ module Lattices = struct
| Regional, Regional -> true

let print ppf = function
| Global -> Format.fprintf ppf "Global"
| Regional -> Format.fprintf ppf "Regional"
| Local -> Format.fprintf ppf "Local"
| Global -> Format.fprintf ppf "global"
| Regional -> Format.fprintf ppf "regional"
| Local -> Format.fprintf ppf "local"
end)

let _is_areality = ()
Expand Down Expand Up @@ -228,8 +230,8 @@ module Lattices = struct
| Shared, Shared -> Shared

let print ppf = function
| Shared -> Format.fprintf ppf "Shared"
| Unique -> Format.fprintf ppf "Unique"
| Shared -> Format.fprintf ppf "shared"
| Unique -> Format.fprintf ppf "unique"
end)
end

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

let print ppf = function
| Once -> Format.fprintf ppf "Once"
| Many -> Format.fprintf ppf "Many"
| Once -> Format.fprintf ppf "once"
| Many -> Format.fprintf ppf "many"
end)
end

Expand Down
2 changes: 2 additions & 0 deletions ocaml/typing/mode_intf.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -127,6 +127,8 @@ module type S = sig

type nonrec disallowed = disallowed

type nonrec equate_step = equate_step

type ('a, 'b) monadic_comonadic =
{ monadic : 'a;
comonadic : 'b
Expand Down
53 changes: 31 additions & 22 deletions ocaml/typing/typecore.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -217,7 +217,7 @@ type error =
Env.closure_context option *
Env.shared_context option
| Local_application_complete of Asttypes.arg_label * [`Prefix|`Single_arg|`Entire_apply]
| Param_mode_mismatch of type_expr * Alloc.equate_error
| Param_mode_mismatch of Alloc.equate_error
| Uncurried_function_escapes of Alloc.error
| Local_return_annotation_mismatch of Location.t
| Function_returns_local
Expand Down Expand Up @@ -847,9 +847,9 @@ let mode_annots_from_pat_attrs pat =
in
Typemode.transl_mode_annots modes, {pat with ppat_attributes}

let apply_mode_annots ~loc ~env ~ty_expected (m : Alloc.Const.Option.t) mode =
let apply_mode_annots ~loc ~env (m : Alloc.Const.Option.t) mode =
let error axis =
raise (Error(loc, env, Param_mode_mismatch (ty_expected, axis)))
raise (Error(loc, env, Param_mode_mismatch axis))
in
Option.iter (fun locality ->
match Locality.equate (Locality.of_const locality) (Alloc.locality mode) with
Expand Down Expand Up @@ -4108,7 +4108,7 @@ let type_approx_fun_one_param
in
Option.iter
(fun mode_annots ->
apply_mode_annots ~loc ~env ~ty_expected mode_annots arg_mode)
apply_mode_annots ~loc ~env mode_annots arg_mode)
mode_annots;
if has_poly then begin
match spato with
Expand Down Expand Up @@ -4781,7 +4781,7 @@ let split_function_ty
generalize_structure ty_arg;
generalize_structure ty_ret)
in
apply_mode_annots ~loc:loc_fun ~env ~ty_expected mode_annots arg_mode;
apply_mode_annots ~loc:loc_fun ~env mode_annots arg_mode;
if not has_poly && not (tpoly_is_mono ty_arg) && !Clflags.principal
&& get_level ty_arg < Btype.generic_level then begin
let snap = Btype.snapshot () in
Expand Down Expand Up @@ -9975,11 +9975,13 @@ let report_error ~loc env = function
| `Regionality _ ->
escaping_hint fail_reason submode_reason closure_context
in
Location.errorf ~loc ~sub begin
Location.errorf ~loc ~sub "%t" begin
match fail_reason with
| `Regionality _ -> "This value escapes its region"
| `Uniqueness _ -> "Found a shared value where a unique value was expected"
| `Linearity _ -> "Found a once value where a many value was expected"
| `Regionality _ -> Format.dprintf "This value escapes its region"
| `Uniqueness {left; right} -> Format.dprintf "Found a %a value where a %a value was expected"
Uniqueness.Const.print left Uniqueness.Const.print right
| `Linearity {left; right} -> Format.dprintf "Found a %a value where a %a value was expected"
Linearity.Const.print left Linearity.Const.print right
end
| Local_application_complete (lbl, loc_kind) ->
let sub =
Expand All @@ -10004,25 +10006,32 @@ let report_error ~loc env = function
Location.errorf ~loc ~sub
"@[This application is complete, but surplus arguments were provided afterwards.@ \
When passing or calling a local value, extra arguments are passed in a separate application.@]"
| Param_mode_mismatch (ty, (_, mkind)) ->
let mkind =
match mkind with
| `Locality _ -> "local"
| `Uniqueness _ -> "unique"
| `Linearity _ -> "once"
in
Location.errorf ~loc
"@[This function has a %s parameter, but was expected to have type:@ %a@]"
mkind Printtyp.type_expr ty
| Param_mode_mismatch (s, mkind) ->
let print_error f (step, {Solver.left; Solver.right}) =
let actual, expected =
match (step : equate_step) with
| Left_le_right -> left, right
| Right_le_left -> right, left
in
Location.errorf ~loc
"@[This function takes a %a parameter,@ \
but was expected to take a %a parameter.@]"
f actual f expected
in begin
match mkind with
| `Locality e -> print_error Locality.Const.print (s, e)
| `Uniqueness e -> print_error Uniqueness.Const.print (s, e)
| `Linearity e -> print_error Linearity.Const.print (s, e)
end
| Uncurried_function_escapes e -> begin
match e with
| `Locality _ ->
Location.errorf ~loc "This function or one of its parameters escape their region @ \
when it is partially applied."
| `Uniqueness _ -> assert false
| `Linearity _ ->
Location.errorf ~loc "This function when partially applied returns a once value,@ \
but expected to be many."
| `Linearity {left; right} ->
Location.errorf ~loc "This function when partially applied returns a %a value,@ \
but expected to be %a." Linearity.Const.print left Linearity.Const.print right
end
| Local_return_annotation_mismatch _ ->
Location.errorf ~loc
Expand Down
2 changes: 1 addition & 1 deletion ocaml/typing/typecore.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -282,7 +282,7 @@ type error =
Mode.Value.error * submode_reason *
Env.closure_context option * Env.shared_context option
| Local_application_complete of Asttypes.arg_label * [`Prefix|`Single_arg|`Entire_apply]
| Param_mode_mismatch of type_expr * Mode.Alloc.equate_error
| Param_mode_mismatch of Mode.Alloc.equate_error
| Uncurried_function_escapes of Mode.Alloc.error
| Local_return_annotation_mismatch of Location.t
| Function_returns_local
Expand Down
Loading