Give more precise error when disambiguation could not possibly work

testsuite/tests/typing-misc/pr7937.ml

@@ -42,9 +42,8 @@ let h: 'a. 'a r -> _ = function true | false -> ();;
 Line 1, characters 32-36:
 1 | let h: 'a. 'a r -> _ = function true | false -> ();;
                                     ^^^^
-Error: This pattern matches values of type bool
-       but a pattern was expected which matches values of type
-         ([< `X of int & 'a ] as 'a) r
+Error: This pattern should not be a boolean literal, the expected type is
+       ([< `X of int & 'a ] as 'a) r
 |}]
 
 
@@ -53,7 +52,6 @@ let i: 'a. 'a r -> _ = function { contents = 0 } -> ();;
 Line 1, characters 32-48:
 1 | let i: 'a. 'a r -> _ = function { contents = 0 } -> ();;
                                     ^^^^^^^^^^^^^^^^
-Error: This pattern matches values of type int ref
-       but a pattern was expected which matches values of type
-         ([< `X of int & 'a ] as 'a) r
+Error: This pattern should not be a record, the expected type is
+       ([< `X of int & 'a ] as 'a) r
 |}]

testsuite/tests/typing-misc/records.ml

@@ -137,8 +137,7 @@ Error: Unbound record field Complex.z
 Line 1, characters 2-6:
 1 | { true with contents = 0 };;
       ^^^^
-Error: This expression has type bool but an expression was expected of type
-         'a ref
+Error: This expression has type bool which is not a record type.
 |}];;
 
 type ('a, 'b) t = { fst : 'a; snd : 'b };;

testsuite/tests/typing-misc/wrong_kind.ml

@@ -0,0 +1,249 @@
+(* TEST
+   * expect
+*)
+
+module Constr = struct
+  type t = A | B | C
+
+  let get _ _ = A
+
+  let put f = ignore (f () : t)
+end
+
+module Record = struct
+  type t = { a : int; b : int; c : int }
+
+  let get _ _ = { a = 0; b = 0; c = 0 }
+
+  let put f = ignore (f () : t)
+end
+
+module Bool = struct
+  type t = true | false
+
+  let get _ _ = true
+
+  let put f = ignore (f () : t)
+end
+
+module List = struct
+  type 'a t = [] | (::) of 'a * 'a t
+
+  let get _ _ = []
+
+  let put f = ignore (f () : int t)
+end
+
+module Unit = struct
+  [@@@warning "-redefining-unit"]
+  type t = ()
+
+  let get _ _ = ()
+
+  let put f = ignore (f (() : unit) : t)
+end;;
+[%%expect{|
+module Constr :
+  sig
+    type t = A | B | C
+    val get : 'a -> 'b -> t
+    val put : (unit -> t) -> unit
+  end
+module Record :
+  sig
+    type t = { a : int; b : int; c : int; }
+    val get : 'a -> 'b -> t
+    val put : (unit -> t) -> unit
+  end
+module Bool :
+  sig
+    type t = true | false
+    val get : 'a -> 'b -> t
+    val put : (unit -> t) -> unit
+  end
+module List :
+  sig
+    type 'a t = [] | (::) of 'a * 'a t
+    val get : 'a -> 'b -> 'c t
+    val put : (unit -> int t) -> unit
+  end
+module Unit :
+  sig type t = () val get : 'a -> 'b -> t val put : (unit -> t) -> unit end
+|}]
+
+let () =
+  match Constr.get () with
+  | A | B | C -> ();;
+[%%expect{|
+Line 3, characters 4-5:
+3 |   | A | B | C -> ();;
+        ^
+Error: This pattern should not be a constructor, the expected type is
+       'a -> Constr.t
+|}]
+
+let () =
+  match Record.get () with
+  | { a; _ } -> ();;
+[%%expect{|
+Line 3, characters 4-12:
+3 |   | { a; _ } -> ();;
+        ^^^^^^^^
+Error: This pattern should not be a record, the expected type is
+       'a -> Record.t
+|}]
+
+let () =
+  match Bool.get () with
+  | true -> ();;
+[%%expect{|
+Line 3, characters 4-8:
+3 |   | true -> ();;
+        ^^^^
+Error: This pattern should not be a boolean literal, the expected type is
+       'a -> Bool.t
+|}]
+
+let () =
+  match Bool.get () with
+  | false -> ();;
+[%%expect{|
+Line 3, characters 4-9:
+3 |   | false -> ();;
+        ^^^^^
+Error: This pattern should not be a boolean literal, the expected type is
+       'a -> Bool.t
+|}]
+
+let () =
+  match List.get () with
+  | [] -> ();;
+[%%expect{|
+Line 3, characters 4-6:
+3 |   | [] -> ();;
+        ^^
+Error: This pattern should not be a list literal, the expected type is
+       'a -> 'b List.t
+|}]
+
+let () =
+  match List.get () with
+  | _ :: _ -> ();;
+[%%expect{|
+Line 3, characters 4-10:
+3 |   | _ :: _ -> ();;
+        ^^^^^^
+Error: This pattern should not be a list literal, the expected type is
+       'a -> 'b List.t
+|}]
+
+let () =
+  match Unit.get () with
+  | () -> ();;
+[%%expect{|
+Line 3, characters 4-6:
+3 |   | () -> ();;
+        ^^
+Error: This pattern should not be a unit literal, the expected type is
+       'a -> Unit.t
+|}]
+
+let () = Constr.put A;;
+[%%expect{|
+Line 1, characters 20-21:
+1 | let () = Constr.put A;;
+                        ^
+Error: This expression should not be a constructor, the expected type is
+       unit -> Constr.t
+|}]
+
+let () = Record.put { a = 0; b = 0; c = 0 };;
+[%%expect{|
+Line 1, characters 20-43:
+1 | let () = Record.put { a = 0; b = 0; c = 0 };;
+                        ^^^^^^^^^^^^^^^^^^^^^^^
+Error: This expression should not be a record, the expected type is
+       unit -> Record.t
+|}]
+
+let () = Bool.put true;;
+[%%expect{|
+Line 1, characters 18-22:
+1 | let () = Bool.put true;;
+                      ^^^^
+Error: This expression should not be a boolean literal, the expected type is
+       unit -> Bool.t
+|}]
+
+let () = Bool.put false;;
+[%%expect{|
+Line 1, characters 18-23:
+1 | let () = Bool.put false;;
+                      ^^^^^
+Error: This expression should not be a boolean literal, the expected type is
+       unit -> Bool.t
+|}]
+
+let () = List.put [];;
+[%%expect{|
+Line 1, characters 18-20:
+1 | let () = List.put [];;
+                      ^^
+Error: This expression should not be a list literal, the expected type is
+       unit -> int List.t
+|}]
+
+let () = List.put (1 :: 2);;
+[%%expect{|
+Line 1, characters 18-26:
+1 | let () = List.put (1 :: 2);;
+                      ^^^^^^^^
+Error: This expression should not be a list literal, the expected type is
+       unit -> int List.t
+|}]
+
+let () = Unit.put ();;
+[%%expect{|
+Line 1, characters 18-20:
+1 | let () = Unit.put ();;
+                      ^^
+Error: This expression should not be a unit literal, the expected type is
+       unit -> Unit.t
+|}]
+
+let () =
+  ignore ((Record.get ()).a);;
+[%%expect{|
+Line 2, characters 10-25:
+2 |   ignore ((Record.get ()).a);;
+              ^^^^^^^^^^^^^^^
+Error: This expression has type 'a -> Record.t which is not a record type.
+|}]
+
+let () =
+  (Record.get ()).a <- 5;;
+[%%expect{|
+Line 2, characters 2-17:
+2 |   (Record.get ()).a <- 5;;
+      ^^^^^^^^^^^^^^^
+Error: This expression has type 'a -> Record.t which is not a record type.
+|}]
+
+let () =
+  ignore { (Record.get ()) with a = 5 };;
+[%%expect{|
+Line 2, characters 11-26:
+2 |   ignore { (Record.get ()) with a = 5 };;
+               ^^^^^^^^^^^^^^^
+Error: This expression has type 'a -> Record.t which is not a record type.
+|}]
+
+let foo x =
+  Record.put { x with a = 5 };;
+[%%expect{|
+Line 2, characters 13-29:
+2 |   Record.put { x with a = 5 };;
+                 ^^^^^^^^^^^^^^^^
+Error: This expression should not be a record, the expected type is
+       unit -> Record.t
+|}]

typing/ctype.ml

@@ -1670,18 +1670,31 @@ let _ = forward_try_expand_safe := try_expand_safe
    called on recursive types
  *)
 
+type typedecl_extraction_result =
+  | Typedecl of Path.t * Path.t * type_declaration
+  | Has_no_typedecl
+  | May_have_typedecl
+
 let rec extract_concrete_typedecl env ty =
   let ty = repr ty in
   match ty.desc with
-    Tconstr (p, _, _) ->
+  | Tconstr (p, _, _) ->
       let decl = Env.find_type p env in
-      if decl.type_kind <> Type_abstract then (p, p, decl) else
-      let ty =
-        try try_expand_safe env ty with Cannot_expand -> raise Not_found
-      in
-      let (_, p', decl) = extract_concrete_typedecl env ty in
-        (p, p', decl)
-  | _ -> raise Not_found
+      if decl.type_kind <> Type_abstract then Typedecl(p, p, decl)
+      else begin
+        match try_expand_safe env ty with
+        | exception Cannot_expand -> May_have_typedecl
+        | ty ->
+            match extract_concrete_typedecl env ty with
+            | Typedecl(_, p', decl) -> Typedecl(p, p', decl)
+            | Has_no_typedecl -> Has_no_typedecl
+            | May_have_typedecl -> May_have_typedecl
+      end
+  | Tpoly(ty, _) -> extract_concrete_typedecl env ty
+  | Tarrow _ | Ttuple _ | Tobject _ | Tfield _ | Tnil
+  | Tvariant _ | Tpackage _ -> Has_no_typedecl
+  | Tvar _ | Tunivar _ -> May_have_typedecl
+  | Tlink _ | Tsubst _ -> assert false
 
 (* Implementing function [expand_head_opt], the compiler's own version of
    [expand_head] used for type-based optimisations.

typing/ctype.mli

@@ -190,11 +190,16 @@ val expand_head_opt: Env.t -> type_expr -> type_expr
     optimisations. *)
 
 val full_expand: may_forget_scope:bool -> Env.t -> type_expr -> type_expr
+
+type typedecl_extraction_result =
+  | Typedecl of Path.t * Path.t * type_declaration
+    (* The original path of the types, and the first concrete
+       type declaration found expanding it. *)
+  | Has_no_typedecl
+  | May_have_typedecl
+
 val extract_concrete_typedecl:
-        Env.t -> type_expr -> Path.t * Path.t * type_declaration
-        (* Return the original path of the types, and the first concrete
-           type declaration found expanding it.
-           Raise [Not_found] if none appears or not a type constructor. *)
+        Env.t -> type_expr -> typedecl_extraction_result
 
 val unify: Env.t -> type_expr -> type_expr -> unit
         (* Unify the two types given. Raise [Unify] if not possible. *)