Finish getting rid of type_sort_exn

Author: goldfirere

ocaml/testsuite/tests/typing-layouts-missing-cmi/function_arg.ml

@@ -20,17 +20,75 @@ script = "rm -f function_a.cmi"
 let f0 (g : Function_b.fun_t) = g ~arg1:(assert false)
 
 [%%expect{|
-blah
+Line 1, characters 40-54:
+1 | let f0 (g : Function_b.fun_t) = g ~arg1:(assert false)
+                                            ^^^^^^^^^^^^^^
+Error: Function arguments and returns must be representable.
+       Function_a.t has an unknown layout, which might not be representable.
+       No .cmi file found containing Function_a.t.
+       Hint: Adding "function_a" to your dependencies might help.
 |}]
 
 let f1 (g : Function_b.fun_t) = g ()
 
 [%%expect{|
-blah
+Line 1, characters 34-36:
+1 | let f1 (g : Function_b.fun_t) = g ()
+                                      ^^
+Error: Function arguments and returns must be representable.
+       Function_a.t has an unknown layout, which might not be representable.
+       No .cmi file found containing Function_a.t.
+       Hint: Adding "function_a" to your dependencies might help.
 |}]
 
 let f2 : Function_b.fun_t = fun ~arg1:_ ~arg2 () -> arg2
 
 [%%expect{|
-blah
+Line 1, characters 28-56:
+1 | let f2 : Function_b.fun_t = fun ~arg1:_ ~arg2 () -> arg2
+                                ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Function arguments and returns must be representable.
+       Function_a.t has an unknown layout, which might not be representable.
+       No .cmi file found containing Function_a.t.
+       Hint: Adding "function_a" to your dependencies might help.
+|}]
+
+let f3 : Function_b.return_t = fun () -> assert false
+
+[%%expect{|
+Line 1, characters 31-53:
+1 | let f3 : Function_b.return_t = fun () -> assert false
+                                   ^^^^^^^^^^^^^^^^^^^^^^
+Error: Function arguments and returns must be representable.
+       Function_a.t has an unknown layout, which might not be representable.
+       No .cmi file found containing Function_a.t.
+       Hint: Adding "function_a" to your dependencies might help.
+|}]
+
+let f4 (_ : Function_b.take_t) = ()
+let x1 = f4 Function_b.f_opt
+
+[%%expect{|
+val f4 : Function_b.take_t -> unit = <fun>
+Line 2, characters 12-28:
+2 | let x1 = f4 Function_b.f_opt
+                ^^^^^^^^^^^^^^^^
+Error: Function arguments and returns must be representable.
+       Function_a.t has an unknown layout, which might not be representable.
+       No .cmi file found containing Function_a.t.
+       Hint: Adding "function_a" to your dependencies might help.
+|}]
+
+let f5 (_ : Function_b.return_t) = ()
+let x2 = f5 Function_b.f_opt_2
+
+[%%expect{|
+val f5 : Function_b.return_t -> unit = <fun>
+Line 2, characters 12-30:
+2 | let x2 = f5 Function_b.f_opt_2
+                ^^^^^^^^^^^^^^^^^^
+Error: Function arguments and returns must be representable.
+       Function_a.t has an unknown layout, which might not be representable.
+       No .cmi file found containing Function_a.t.
+       Hint: Adding "function_a" to your dependencies might help.
 |}]

ocaml/testsuite/tests/typing-layouts-missing-cmi/function_b.ml

@@ -1,3 +1,9 @@
 
 type fun_t = arg1:Function_a.t -> arg2:Function_a.t -> unit -> Function_a.t
 
+type take_t = Function_a.t -> unit
+type return_t = unit -> Function_a.t
+
+let f_opt : ?opt:int -> Function_a.t -> unit = fun ?opt _ -> ()
+let f_opt_2 : ?opt:int -> unit -> Function_a.t = fun ?opt _ -> assert false
+

ocaml/typing/ctype.ml

@@ -2075,11 +2075,6 @@ let type_sort ~why env ty =
   | Ok _ -> Ok sort
   | Error _ as e -> e
 
-let type_sort_exn ~why env ty =
-  match type_sort ~why env ty with
-  | Ok s -> s
-  | Error _ -> Misc.fatal_error "Ctype.type_sort_exn on non-sort"
-
 (* Note: Because [estimate_type_layout] actually returns an upper bound, this
    function computes an inaccurate intersection in some cases.
 
@@ -3764,6 +3759,7 @@ type filter_arrow_failure =
       ; expected_type : type_expr
       }
   | Not_a_function
+  | Layout_error of type_expr * Layout.Violation.t
 
 exception Filter_arrow_failed of filter_arrow_failure
 
@@ -3842,8 +3838,13 @@ let filter_arrow env t l ~force_tpoly =
            entirely by storing sorts on [TArrow], but that seems incompatible
            with the future plan to shift the layout requirements from the types
            to the terms. *)
-        let arg_sort = type_sort_exn ~why:Function_argument env ty_arg in
-        let ret_sort = type_sort_exn ~why:Function_argument env ty_ret in
+        let type_sort ~why ty =
+          match type_sort ~why env ty with
+          | Ok sort -> sort
+          | Error err -> raise (Filter_arrow_failed (Layout_error (ty, err)))
+        in
+        let arg_sort = type_sort ~why:Function_argument ty_arg in
+        let ret_sort = type_sort ~why:Function_result ty_ret in
         { ty_arg; arg_mode; arg_sort; ty_ret; ret_mode; ret_sort }
       else raise (Filter_arrow_failed
                     (Label_mismatch

ocaml/typing/ctype.mli

@@ -301,6 +301,7 @@ type filter_arrow_failure =
       ; expected_type : type_expr
       }
   | Not_a_function
+  | Layout_error of type_expr * Layout.Violation.t
 
 exception Filter_arrow_failed of filter_arrow_failure
 
@@ -494,12 +495,6 @@ val type_sort :
   why:Layouts.Layout.concrete_layout_reason ->
   Env.t -> type_expr -> (sort, Layout.Violation.t) result
 
-(* Same as [type_sort], but only safe to call on types known to be a sort.
-   For example, if the type is used as an argument in a function type that
-   has already been translated. *)
-val type_sort_exn :
-  why:Layouts.Layout.concrete_layout_reason -> Env.t -> type_expr -> sort
-
 (* Layout checking. [constrain_type_layout] will update the layout of type
    variables to make the check true, if possible.  [check_decl_layout] and
    [check_type_layout] won't, but will still instantiate sort variables.

ocaml/typing/typecore.ml

@@ -191,11 +191,24 @@ type error =
   | Layout_not_enabled of Layout.const
   | Unboxed_int_literals_not_supported
   | Unboxed_float_literals_not_supported
-  | Function_arg_not_rep of type_expr * Layout.Violation.t
+  | Function_type_not_rep of type_expr * Layout.Violation.t
 
 exception Error of Location.t * Env.t * error
 exception Error_forward of Location.error
 
+let error_of_filter_arrow_failure ~explanation in_function ty_fun
+  : filter_arrow_failure -> _ = function
+  | Unification_error unif_err ->
+      Expr_type_clash(unif_err, explanation, None)
+  | Label_mismatch { got; expected; expected_type} ->
+      Abstract_wrong_label { got; expected; expected_type; explanation }
+  | Not_a_function -> begin
+      match in_function with
+      | Some _ -> Too_many_arguments(ty_fun, explanation)
+      | None   -> Not_a_function(ty_fun, explanation)
+    end
+  | Layout_error (ty, err) -> Function_type_not_rep (ty, err)
+
 (* Forward declaration, to be filled in by Typemod.type_module *)
 
 let type_module =
@@ -3119,7 +3132,7 @@ let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs ret_tvar
               match type_sort ~why:Function_argument env ty_arg with
               | Ok sort -> sort
               | Error err -> raise(Error(funct.exp_loc, env,
-                                         Function_arg_not_rep (ty_arg,err)))
+                                         Function_type_not_rep (ty_arg,err)))
             in
             (sort_arg, mode_arg, tpoly_get_mono ty_arg, mode_ret, ty_res)
         | td ->
@@ -3164,7 +3177,7 @@ let collect_apply_args env funct ignore_labels ty_fun ty_fun0 mode_fun sargs ret
         let sort_arg = match type_sort ~why:Function_argument env ty_arg with
           | Ok sort -> sort
           | Error err -> raise(Error(sarg1.pexp_loc, env,
-                                     Function_arg_not_rep(ty_arg, err)))
+                                     Function_type_not_rep(ty_arg, err)))
         in
         let name = label_name l
         and optional = is_optional l in
@@ -3623,17 +3636,8 @@ let rec type_function_approx env loc label spato sexp in_function ty_expected =
   let { ty_arg; arg_mode; ty_ret; _ } =
     try filter_arrow env ty_expected label ~force_tpoly:(not has_poly)
     with Filter_arrow_failed err ->
-      let explanation = None in
-      let err = match err with
-        | Unification_error unif_err ->
-            Expr_type_clash(unif_err, explanation, None)
-        | Label_mismatch { got; expected; expected_type} ->
-            Abstract_wrong_label { got; expected; expected_type; explanation }
-        | Not_a_function -> begin
-            match in_function with
-            | Some _ -> Too_many_arguments(ty_fun, explanation)
-            | None   -> Not_a_function(ty_fun, explanation)
-          end
+      let err =
+        error_of_filter_arrow_failure ~explanation:None in_function ty_fun err
       in
       raise (Error(loc_fun, env, err))
   in
@@ -5762,16 +5766,8 @@ and type_function ?in_function loc attrs env (expected_mode : expected_mode)
     in
     try filter_arrow env ty_expected' arg_label ~force_tpoly
     with Filter_arrow_failed err ->
-      let err = match err with
-        | Unification_error unif_err ->
-            Expr_type_clash(unif_err, explanation, None)
-        | Label_mismatch { got; expected; expected_type} ->
-            Abstract_wrong_label { got; expected; expected_type; explanation }
-        | Not_a_function -> begin
-            match in_function with
-            | Some _ -> Too_many_arguments(ty_fun, explanation)
-            | None   -> Not_a_function(ty_fun, explanation)
-          end
+      let err =
+        error_of_filter_arrow_failure ~explanation in_function ty_fun err
       in
       raise (Error(loc_fun, env, err))
   in
@@ -6372,10 +6368,17 @@ and type_argument ?explanation ?recarg env (mode : expected_mode) sarg
       let eta_mode = Value_mode.local_to_regional (Value_mode.of_alloc marg) in
       let eta_pat, eta_var = var_pair ~mode:eta_mode "eta" ty_arg in
       (* CR layouts v10: When we add abstract layouts, the eta expansion here
-         becomes impossible in some cases - we'll need good errors and test
-         cases instead of `type_sort_exn`. *)
-      let arg_sort = type_sort_exn env ~why:Function_argument ty_arg in
-      let ret_sort = type_sort_exn env ~why:Function_argument ty_res in
+         becomes impossible in some cases - we'll need better errors.  For test
+         cases, look toward the end of
+         typing-layouts-missing-cmi/function_arg.ml *)
+      let type_sort ~why ty =
+        match type_sort ~why env ty with
+        | Ok sort -> sort
+        | Error err ->
+          raise(Error(sarg.pexp_loc, env, Function_type_not_rep (ty, err)))
+      in
+      let arg_sort = type_sort ~why:Function_argument ty_arg in
+      let ret_sort = type_sort ~why:Function_result ty_res in
       let func texp =
         let ret_mode = Value_mode.of_alloc mret in
         let e =
@@ -8365,12 +8368,11 @@ let report_error ~loc env = function
   | Unboxed_float_literals_not_supported ->
       Location.errorf ~loc
         "@[Unboxed float literals aren't supported yet.@]"
-  | Function_arg_not_rep (ty_arg,violation) ->
+  | Function_type_not_rep (ty,violation) ->
       Location.errorf ~loc
-        "@[Function argument of type %a@ is not representable.@]@ %a"
-        Printtyp.type_expr ty_arg
+        "@[Function arguments and returns must be representable.@]@ %a"
         (Layout.Violation.report_with_offender
-           ~offender:(fun ppf -> Printtyp.type_expr ppf ty_arg)) violation
+           ~offender:(fun ppf -> Printtyp.type_expr ppf ty)) violation
 
 let report_error ~loc env err =
   Printtyp.wrap_printing_env ~error:true env

ocaml/typing/typecore.mli

@@ -268,7 +268,7 @@ type error =
   | Layout_not_enabled of Layout.const
   | Unboxed_int_literals_not_supported
   | Unboxed_float_literals_not_supported
-  | Function_arg_not_rep of type_expr * Layout.Violation.t
+  | Function_type_not_rep of type_expr * Layout.Violation.t
 
 exception Error of Location.t * Env.t * error
 exception Error_forward of Location.error