Skip to content

Commit

Permalink
Fix class related tests and reduce diff with upstream
Browse files Browse the repository at this point in the history
  • Loading branch information
@voodoos
voodoos committed Dec 12, 2024
1 parent 5b03126 commit cdf1bb4
Show file tree
Hide file tree
Showing 5 changed files with 97 additions and 140 deletions.
32 changes: 16 additions & 16 deletions src/ocaml/typing/typeclass.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1840,9 +1840,8 @@ let type_classes define_class approx kind env cls =
))
cls
in

let res, newenv =
Ctype.with_local_level_for_class begin fun () ->
let res, env =
Ctype.with_local_level_generalize_for_class begin fun () ->
let (res, env) =
List.fold_left (initial_env define_class approx) ([], env) cls
in
Expand All @@ -1853,10 +1852,10 @@ let type_classes define_class approx kind env cls =
res, env
end
in
let res = List.rev_map (final_decl newenv define_class) res in
let res = List.rev_map (final_decl env define_class) res in
let decls = List.fold_right extract_type_decls res [] in
let decls =
try Typedecl_variance.update_class_decls newenv decls
try Typedecl_variance.update_class_decls env decls
with Typedecl_variance.Error(loc, err) ->
raise (Typedecl.Error(loc, Typedecl.Variance err))
in
Expand Down Expand Up @@ -1978,9 +1977,10 @@ let non_virtual_string_of_kind : kind -> string = function
| Class_type -> "non-virtual class type"

module Style=Misc.Style
module Printtyp = Printtyp.Doc

let out_type ppf t = Style.as_inline_code !Oprint.out_type ppf t
let quoted_type ppf t = Style.as_inline_code Printtyp.Doc.type_expr ppf t
let quoted_type ppf t = Style.as_inline_code Printtyp.type_expr ppf t

let report_error_doc env ppf =
let pp_args ppf args =
Expand Down Expand Up @@ -2011,7 +2011,7 @@ let report_error_doc env ppf =
| Structure_expected clty ->
fprintf ppf
"@[This class expression is not a class structure; it has type@ %a@]"
(Style.as_inline_code Printtyp.Doc.class_type) clty
(Style.as_inline_code Printtyp.class_type) clty
| Cannot_apply _ ->
fprintf ppf
"This class expression is not a class function, it cannot be applied"
Expand All @@ -2030,10 +2030,10 @@ let report_error_doc env ppf =
quoted_type ty
| Unbound_class_2 cl ->
fprintf ppf "@[The class@ %a@ is not yet completely defined@]"
(Style.as_inline_code Printtyp.Doc.longident) cl
(Style.as_inline_code Printtyp.longident) cl
| Unbound_class_type_2 cl ->
fprintf ppf "@[The class type@ %a@ is not yet completely defined@]"
(Style.as_inline_code Printtyp.Doc.longident) cl
(Style.as_inline_code Printtyp.longident) cl
| Abbrev_type_clash (abbrev, actual, expected) ->
(* XXX Afficher une trace ? | Print a trace? *)
Out_type.prepare_for_printing [abbrev; actual; expected];
Expand Down Expand Up @@ -2072,7 +2072,7 @@ let report_error_doc env ppf =
fprintf ppf
"@[The class constructor %a@ expects %i type argument(s),@ \
but is here applied to %i type argument(s)@]"
(Style.as_inline_code Printtyp.Doc.longident) lid expected provided
(Style.as_inline_code Printtyp.longident) lid expected provided
| Parameter_mismatch err ->
let msg = Format_doc.Doc.msg in
Errortrace_report.unification ppf env err
Expand All @@ -2083,11 +2083,11 @@ let report_error_doc env ppf =
fprintf ppf
"@[The abbreviation %a@ is used with parameter(s)@ %a@ \
which are incompatible with constraint(s)@ %a@]"
(Style.as_inline_code Printtyp.Doc.ident) id
(Style.as_inline_code Printtyp.ident) id
pp_args params
pp_args cstrs
| Bad_class_type_parameters (id, params, cstrs) ->
let pp_hash ppf id = fprintf ppf "#%a" Printtyp.Doc.ident id in
let pp_hash ppf id = fprintf ppf "#%a" Printtyp.ident id in
Out_type.prepare_for_printing (params @ cstrs);
fprintf ppf
"@[The class type %a@ is used with parameter(s)@ %a,@ \
Expand Down Expand Up @@ -2126,7 +2126,7 @@ let report_error_doc env ppf =
fprintf ppf
"@[The type of this class,@ %a,@ \
contains the non-generalizable type variable(s): %a.@ %a@]"
(Style.as_inline_code @@ Printtyp.Doc.class_declaration id) clty
(Style.as_inline_code @@ Printtyp.class_declaration id) clty
(pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ")
(Style.as_inline_code Out_type.prepared_type_scheme)
) nongen_vars
Expand All @@ -2137,13 +2137,13 @@ let report_error_doc env ppf =
"@[The type of self cannot be coerced to@ \
the type of the current class:@ %a.@.\
Some occurrences are contravariant@]"
(Style.as_inline_code Printtyp.Doc.type_scheme) ty
(Style.as_inline_code Printtyp.type_scheme) ty
| Non_collapsable_conjunction (id, clty, err) ->
let msg = Format_doc.Doc.msg in
fprintf ppf
"@[The type of this class,@ %a,@ \
contains non-collapsible conjunctive types in constraints.@ %t@]"
(Style.as_inline_code @@ Printtyp.Doc.class_declaration id) clty
(Style.as_inline_code @@ Printtyp.class_declaration id) clty
(fun ppf -> Errortrace_report.unification ppf env err
(msg "Type")
(msg "is not compatible with type")
Expand Down Expand Up @@ -2177,7 +2177,7 @@ let report_error_doc env ppf =
"@[Cannot close type of object literal:@ %a@,\
it has been unified with the self type of a class that is not yet@ \
completely defined.@]"
(Style.as_inline_code Printtyp.Doc.type_scheme) sign.csig_self
(Style.as_inline_code Printtyp.type_scheme) sign.csig_self

let report_error_doc env ppf err =
Printtyp.wrap_printing_env ~error:true
Expand Down
4 changes: 4 additions & 0 deletions tests/test-dirs/construct/c-modules.t/run.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -40,6 +40,10 @@ Simple module construction
let i = _
let f = _
module Sub = struct let y = _ end
[@@@ocaml.text
\"Construct does not handle class types yet. Please replace this comment by [room]'s definition.\"]
[@@@ocaml.text
\"Construct does not handle classes yet. Please replace this comment by [croom]'s definition.\"]
module type Another = sig val i : int end
module type Sig =
sig
Expand Down
31 changes: 31 additions & 0 deletions tests/test-dirs/outline.t/run.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -125,6 +125,37 @@
"children": [],
"deprecated": false
},
{
"start": {
"line": 14,
"col": 0
},
"end": {
"line": 16,
"col": 3
},
"name": "class_b",
"kind": "Class",
"type": null,
"children": [
{
"start": {
"line": 15,
"col": 9
},
"end": {
"line": 15,
"col": 10
},
"name": "b",
"kind": "Method",
"type": null,
"children": [],
"deprecated": false
}
],
"deprecated": false
},
{
"start": {
"line": 1,
Expand Down
138 changes: 16 additions & 122 deletions tests/test-dirs/short-paths.t/run.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -4,39 +4,6 @@
{
"class": "return",
"value": [
{
"start": {
"line": 4,
"col": 2
},
"end": {
"line": 6,
"col": 5
},
"type": "typer",
"sub": [],
"valid": true,
"message": "The type of this class,
class virtual x : object method private virtual release : unit end,
contains the non-generalizable type variable(s): '_weak11.
(see manual section 6.1.2)"
},
{
"start": {
"line": 11,
"col": 2
},
"end": {
"line": 14,
"col": 7
},
"type": "typer",
"sub": [],
"valid": true,
"message": "The type of this class, class c : object method private release : unit end,
contains the non-generalizable type variable(s): '_weak10.
(see manual section 6.1.2)"
},
{
"start": {
"line": 21,
Expand All @@ -49,9 +16,8 @@
"type": "typer",
"sub": [],
"valid": true,
"message": "The type of this class, class b : '_weak6 -> a,
contains the non-generalizable type variable(s): '_weak9.
(see manual section 6.1.2)"
"message": "Some type variables are unbound in this type: class b : 'a -> a
The method x has type 'c where 'c is unbound"
},
{
"start": {
Expand Down Expand Up @@ -79,10 +45,9 @@
"type": "typer",
"sub": [],
"valid": true,
"message": "The type of this class,
class test : ?a:'_weak4 -> object method b : '_weak5 end,
contains the non-generalizable type variable(s): '_weak6, '_weak7, '_weak8.
(see manual section 6.1.2)"
"message": "Some type variables are unbound in this type:
class test : ?a:'a -> object method b : 'b end
The method b has type 'b where 'b is unbound"
},
{
"start": {
Expand Down Expand Up @@ -124,10 +89,9 @@
"type": "typer",
"sub": [],
"valid": true,
"message": "The type of this class,
class test : '_weak2 -> object method b : '_weak3 end,
contains the non-generalizable type variable(s): '_weak3, '_weak4, '_weak5.
(see manual section 6.1.2)"
"message": "Some type variables are unbound in this type:
class test : 'a -> object method b : 'b end
The method b has type 'a where 'a is unbound"
},
{
"start": {
Expand All @@ -143,23 +107,6 @@
"valid": true,
"message": "Unbound value c"
},
{
"start": {
"line": 39,
"col": 0
},
"end": {
"line": 42,
"col": 3
},
"type": "typer",
"sub": [],
"valid": true,
"message": "The type of this class,
class test : ?a:'_weak1 -> object method b : unit end,
contains the non-generalizable type variable(s): '_weak1, '_weak2.
(see manual section 6.1.2)"
},
{
"start": {
"line": 39,
Expand Down Expand Up @@ -233,39 +180,6 @@
{
"class": "return",
"value": [
{
"start": {
"line": 4,
"col": 2
},
"end": {
"line": 6,
"col": 5
},
"type": "typer",
"sub": [],
"valid": true,
"message": "The type of this class,
class virtual x : object method private virtual release : unit end,
contains the non-generalizable type variable(s): '_weak11.
(see manual section 6.1.2)"
},
{
"start": {
"line": 11,
"col": 2
},
"end": {
"line": 14,
"col": 7
},
"type": "typer",
"sub": [],
"valid": true,
"message": "The type of this class, class c : object method private release : unit end,
contains the non-generalizable type variable(s): '_weak10.
(see manual section 6.1.2)"
},
{
"start": {
"line": 21,
Expand All @@ -278,9 +192,8 @@
"type": "typer",
"sub": [],
"valid": true,
"message": "The type of this class, class b : '_weak6 -> a,
contains the non-generalizable type variable(s): '_weak9.
(see manual section 6.1.2)"
"message": "Some type variables are unbound in this type: class b : 'a -> a
The method x has type 'c where 'c is unbound"
},
{
"start": {
Expand Down Expand Up @@ -308,10 +221,9 @@
"type": "typer",
"sub": [],
"valid": true,
"message": "The type of this class,
class test : ?a:'_weak4 -> object method b : '_weak5 end,
contains the non-generalizable type variable(s): '_weak6, '_weak7, '_weak8.
(see manual section 6.1.2)"
"message": "Some type variables are unbound in this type:
class test : ?a:'a -> object method b : 'b end
The method b has type 'b where 'b is unbound"
},
{
"start": {
Expand Down Expand Up @@ -353,10 +265,9 @@
"type": "typer",
"sub": [],
"valid": true,
"message": "The type of this class,
class test : '_weak2 -> object method b : '_weak3 end,
contains the non-generalizable type variable(s): '_weak3, '_weak4, '_weak5.
(see manual section 6.1.2)"
"message": "Some type variables are unbound in this type:
class test : 'a -> object method b : 'b end
The method b has type 'a where 'a is unbound"
},
{
"start": {
Expand All @@ -372,23 +283,6 @@
"valid": true,
"message": "Unbound value c"
},
{
"start": {
"line": 39,
"col": 0
},
"end": {
"line": 42,
"col": 3
},
"type": "typer",
"sub": [],
"valid": true,
"message": "The type of this class,
class test : ?a:'_weak1 -> object method b : unit end,
contains the non-generalizable type variable(s): '_weak1, '_weak2.
(see manual section 6.1.2)"
},
{
"start": {
"line": 39,
Expand Down
Loading

0 comments on commit cdf1bb4

Please sign in to comment.