Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Printing additional info about types mismatch during compilation error.

master
Mekhrubon Turaev 2019-07-11 10:29:44 +01:00
parent 0569b396ec
commit 407d650f6e
21 changed files with 270 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
testsuite/tests/typing-extensions/extensions.ml
View File

@ -296,7 +296,11 @@ Error: Signature mismatch:
type ('a, 'b) bar += A of float
is not included in
type ('a, 'b) bar += A of int
The types for constructor A are not equal.
Constructors do not match:
A of float
is not compatible with:
A of int
The types are not equal.
|}]
module M : sig
@ -318,7 +322,11 @@ Error: Signature mismatch:
type ('a, 'b) bar += A of 'b
is not included in
type ('a, 'b) bar += A of 'a
The types for constructor A are not equal.
Constructors do not match:
A of 'b
is not compatible with:
A of 'a0
The types are not equal.
|}]
module M : sig
@ -340,7 +348,11 @@ Error: Signature mismatch:
type ('a, 'b) bar += A : 'd -> ('c, 'd) bar
is not included in
type ('a, 'b) bar += A : 'c -> ('c, 'd) bar
The types for constructor A are not equal.
Constructors do not match:
A : 'd -> ('c, 'd) bar
is not compatible with:
A : 'c -> ('c, 'd) bar
The types are not equal.
|}]
(* Extensions can be rebound *)

6
testsuite/tests/typing-gadts/pr7160.ml
View File

@ -18,5 +18,9 @@ Lines 4-5, characters 0-77:
4 | type 'a tt = 'a t =
5 | Int : int -> int tt | String : string -> string tt | Same : 'l1 t -> 'l2 tt..
Error: This variant or record definition does not match that of type 'a t
The types for constructor Same are not equal.
Constructors do not match:
Same : 'l t -> 'l t
is not compatible with:
Same : 'l1 t -> 'l2 t
The types are not equal.
|}];;

6
testsuite/tests/typing-gadts/pr7378.ml
View File

@ -19,7 +19,11 @@ Lines 2-3, characters 2-37:
2 | ..type t = X.t =
3 | | A : 'a * 'b * ('b -> unit) -> t
Error: This variant or record definition does not match that of type X.t
The types for constructor A are not equal.
Constructors do not match:
A : 'a * 'b * ('a -> unit) -> X.t
is not compatible with:
A : 'a * 'b * ('b -> unit) -> X.t
The types are not equal.
|}]
(* would segfault

12
testsuite/tests/typing-misc/pr6416.ml
View File

@ -50,7 +50,11 @@ Error: Signature mismatch:
type u = A of t/1
is not included in
type u = A of t/2
The types for constructor A are not equal.
Constructors do not match:
A of t/1
is not compatible with:
A of t/2
The types are not equal.
Line 4, characters 9-19:
Definition of type t/1
Line 2, characters 2-11:
@ -113,7 +117,11 @@ Error: Signature mismatch:
type t = A of T/1.t
is not included in
type t = A of T/2.t
The types for constructor A are not equal.
Constructors do not match:
A of T/1.t
is not compatible with:
A of T/2.t
The types are not equal.
Line 5, characters 6-34:
Definition of module T/1
Line 2, characters 2-30:

14
testsuite/tests/typing-misc/records.ml
View File

@ -208,7 +208,11 @@ Line 2, characters 0-37:
2 | type mut = d = {x:int; mutable y:int}
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This variant or record definition does not match that of type d
The mutability of field y is different.
Fields do not match:
y : int;
is not compatible with:
mutable y : int;
This is mutable and the original is not.
|}]
type missing = d = { x:int }
@ -226,7 +230,11 @@ Line 1, characters 0-31:
1 | type wrong_type = d = {x:float}
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This variant or record definition does not match that of type d
The types for field x are not equal.
Fields do not match:
x : int;
is not compatible with:
x : float;
The types are not equal.
|}]
type unboxed = d = {x:float} [@@unboxed]
@ -245,5 +253,5 @@ Line 1, characters 0-30:
1 | type perm = d = {y:int; x:int}
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This variant or record definition does not match that of type d
Fields number 1 have different names, x and y.
1st fields have different names, x and y.
|}]

12
testsuite/tests/typing-misc/variant.ml
View File

@ -96,7 +96,11 @@ Line 1, characters 0-32:
1 | type wrong_type = d = X of float
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This variant or record definition does not match that of type d
The types for constructor X are not equal.
Constructors do not match:
X of int
is not compatible with:
X of float
The types are not equal.
|}]
type unboxed = d = X of float [@@unboxed]
@ -115,7 +119,7 @@ Line 1, characters 0-35:
1 | type perm = d = Y of int | X of int
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This variant or record definition does not match that of type d
Constructors number 1 have different names, X and Y.
1st constructors have different names, X and Y.
|}]
module M : sig
@ -137,5 +141,9 @@ Error: Signature mismatch:
type t = Foo : int -> t
is not included in
type t = Foo of int
Constructors do not match:
Foo : int -> t
is not compatible with:
Foo of int
The first has explicit return type and the second doesn't.
|}]

24
testsuite/tests/typing-modules/Test.ml
View File

@ -95,7 +95,11 @@ Line 3, characters 23-33:
3 | module type B = A with type t = u;; (* fail *)
^^^^^^^^^^
Error: This variant or record definition does not match that of type u
The types for constructor X are not equal.
Constructors do not match:
X of bool
is not compatible with:
X of int
The types are not equal.
|}];;
(* PR#5815 *)
@ -141,7 +145,11 @@ Error: Signature mismatch:
type t += E of int
is not included in
type t += E
The arities for constructor E differ.
Constructors do not match:
E of int
is not compatible with:
E
They have different arities.
|}];;
module M : sig type t += E of char end = struct type t += E of int end;;
@ -158,7 +166,11 @@ Error: Signature mismatch:
type t += E of int
is not included in
type t += E of char
The types for constructor E are not equal.
Constructors do not match:
E of int
is not compatible with:
E of char
The types are not equal.
|}];;
module M : sig type t += C of int end = struct type t += E of int end;;
@ -193,5 +205,9 @@ Error: Signature mismatch:
type t += E of int
is not included in
type t += E of { x : int; }
The types for constructor E are not equal.
Constructors do not match:
E of int
is not compatible with:
E of { x : int; }
The second uses inline records and the first doesn't.
|}];;

6
testsuite/tests/typing-modules/extension_constructors_errors_test.ml
View File

@ -19,7 +19,11 @@ Error: Signature mismatch:
type t += F of int
is not included in
type t += F
The arities for field F differ.
Constructors do not match:
F of int
is not compatible with:
F
They have different arities.
|}];;
module M1 : sig type t += A end = struct type t += private A end;;

6
testsuite/tests/typing-modules/pr7818.ml
View File

@ -315,5 +315,9 @@ Line 15, characters 16-64:
15 | module rec M1 : S' with module Term0 := Asc and module T := Desc = M1;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This variant or record definition does not match that of type M.t
The types for constructor E are not equal.
Constructors do not match:
E of (MkT(M.T).t, MkT(M.T).t) eq
is not compatible with:
E of (MkT(Desc).t, MkT(Desc).t) eq
The types are not equal.
|}]

12
testsuite/tests/typing-modules/pr7851.ml
View File

@ -27,7 +27,11 @@ Line 1, characters 16-53:
1 | module rec M1 : S with type x = int and type y = bool = M1;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This variant or record definition does not match that of type M1.t
The types for constructor E are not equal.
Constructors do not match:
E of M1.x
is not compatible with:
E of M1.y
The types are not equal.
|}]
let bool_of_int x =
@ -75,5 +79,9 @@ Line 1, characters 16-53:
1 | module rec M1 : S with type x = int and type y = bool = M1;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This variant or record definition does not match that of type M1.t
The types for constructor E are not equal.
Constructors do not match:
E of (M1.x, M1.x) eq
is not compatible with:
E of (M1.x, M1.y) eq
The types are not equal.
|}]

14
testsuite/tests/typing-modules/records_errors_test.ml
View File

@ -40,7 +40,11 @@ Error: Signature mismatch:
f0 : unit * unit * unit * int * unit * unit * unit;
f1 : unit * unit * unit * int * unit * unit * unit;
}
The types for field f0 are not equal.
Fields do not match:
f0 : unit * unit * unit * float * unit * unit * unit;
is not compatible with:
f0 : unit * unit * unit * int * unit * unit * unit;
The types are not equal.
|}];;
@ -82,7 +86,11 @@ Error: Signature mismatch:
mutable f0 : unit * unit * unit * int * unit * unit * unit;
f1 : unit * unit * unit * int * unit * unit * unit;
}
The mutability of field f0 is different.
Fields do not match:
f0 : unit * unit * unit * float * unit * unit * unit;
is not compatible with:
mutable f0 : unit * unit * unit * int * unit * unit * unit;
The second is mutable and the first is not.
|}];;
module M3 : sig
@ -104,7 +112,7 @@ Error: Signature mismatch:
type t = { f1 : unit; }
is not included in
type t = { f0 : unit; }
Fields number 1 have different names, f1 and f0.
1st fields have different names, f1 and f0.
|}];;
module M4 : sig

34
testsuite/tests/typing-modules/variants_errors_test.ml
View File

@ -24,7 +24,11 @@ Error: Signature mismatch:
type t = Foo of float * int
is not included in
type t = Foo of int * int
The types for field Foo are not equal.
Constructors do not match:
Foo of float * int
is not compatible with:
Foo of int * int
The types are not equal.
|}];;
module M2 : sig
@ -49,7 +53,11 @@ Error: Signature mismatch:
type t = Foo of float
is not included in
type t = Foo of int * int
The arities for field Foo differ.
Constructors do not match:
Foo of float
is not compatible with:
Foo of int * int
They have different arities.
|}];;
module M3 : sig
@ -74,7 +82,15 @@ Error: Signature mismatch:
type t = Foo of { x : float; y : int; }
is not included in
type t = Foo of { x : int; y : int; }
The types for field x are not equal.
Constructors do not match:
Foo of { x : float; y : int; }
is not compatible with:
Foo of { x : int; y : int; }
Fields do not match:
x : float;
is not compatible with:
x : int;
The types are not equal.
|}];;
module M4 : sig
@ -99,7 +115,11 @@ Error: Signature mismatch:
type t = Foo of float
is not included in
type t = Foo of { x : int; y : int; }
The types for field Foo are not equal.
Constructors do not match:
Foo of float
is not compatible with:
Foo of { x : int; y : int; }
The second uses inline records and the first doesn't.
|}];;
module M5 : sig
@ -124,5 +144,9 @@ Error: Signature mismatch:
type 'a t = Foo of 'a
is not included in
type 'a t = Foo : int -> int t
The types for field Foo are not equal.
Constructors do not match:
Foo of 'a
is not compatible with:
Foo : int -> int t
The second has explicit return type and the first doesn't.
|}];;

111
typing/includecore.ml
View File

@ -135,29 +135,37 @@ let choose_other ord first second =
| Second -> choose First first second
type label_mismatch =
| Type of Ident.t
| Mutability of Ident.t
| Type
| Mutability of position
type record_mismatch =
| Label_mismatch of label_mismatch
| Label_mismatch of Types.label_declaration
* Types.label_declaration
* label_mismatch
| Label_names of int * Ident.t * Ident.t
| Label_missing of position * Ident.t
| Unboxed_float_representation of position
type constructor_mismatch =
| Type of Ident.t
| Arity of Ident.t
| Type
| Arity
| Inline_record of record_mismatch
| Kind of position
| Explicit_return_type of position
type variant_mismatch =
| Constructor_mismatch of constructor_mismatch
| Constructor_mismatch of Types.constructor_declaration
* Types.constructor_declaration
* constructor_mismatch
| Constructor_names of int * Ident.t * Ident.t
| Constructor_missing of position * Ident.t
type extension_constructor_mismatch =
| Constructor_privacy
| Constructor_mismatch of constructor_mismatch
| Constructor_mismatch of Ident.t
* Types.extension_constructor
* Types.extension_constructor
* constructor_mismatch
type type_mismatch =
| Arity
@ -171,20 +179,28 @@ type type_mismatch =
| Unboxed_representation of position
| Immediate
let report_label_mismatch ppf err =
let report_label_mismatch first second ppf err =
let pr fmt = Format.fprintf ppf fmt in
match (err : label_mismatch) with
| Type s -> pr "The types for field %s are not equal." (Ident.name s)
| Mutability s ->
pr "The mutability of field %s is different." (Ident.name s)
| Type -> pr "The types are not equal."
| Mutability ord ->
pr "%s is mutable and %s is not."
(String.capitalize_ascii (choose ord first second))
(choose_other ord first second)
let report_record_mismatch first second decl ppf err =
let pr fmt = Format.fprintf ppf fmt in
match (err : record_mismatch) with
| Label_mismatch err -> report_label_mismatch ppf err
match err with
| Label_mismatch (l1, l2, err) ->
pr
"@[<hv>Fields do not match:@;<1 2>%a@ is not compatible with:\
@;<1 2>%a@ %a"
Printtyp.label l1
Printtyp.label l2
(report_label_mismatch first second) err
| Label_names (n, name1, name2) ->
pr "@[<hv>Fields number %i have different names, %s and %s.@]"
n (Ident.name name1) (Ident.name name2)
pr "@[<hv>%i%s fields have different names, %s and %s.@]"
n (Misc.suffix n) (Ident.name name1) (Ident.name name2)
| Label_missing (ord, s) ->
pr "@[<hv>The field %s is only present in %s %s.@]"
(Ident.name s) (choose ord first second) decl
@ -196,9 +212,13 @@ let report_record_mismatch first second decl ppf err =
let report_constructor_mismatch first second decl ppf err =
let pr fmt = Format.fprintf ppf fmt in
match (err : constructor_mismatch) with
| Type s -> pr "The types for constructor %s are not equal." (Ident.name s)
| Arity s -> pr "The arities for constructor %s differ." (Ident.name s)
| Type -> pr "The types are not equal."
| Arity -> pr "They have different arities."
| Inline_record err -> report_record_mismatch first second decl ppf err
| Kind ord ->
pr "%s uses inline records and %s doesn't."
(String.capitalize_ascii (choose ord first second))
(choose_other ord first second)
| Explicit_return_type ord ->
pr "%s has explicit return type and %s doesn't."
(String.capitalize_ascii (choose ord first second))
@ -207,11 +227,16 @@ let report_constructor_mismatch first second decl ppf err =
let report_variant_mismatch first second decl ppf err =
let pr fmt = Format.fprintf ppf fmt in
match (err : variant_mismatch) with
| Constructor_mismatch err ->
report_constructor_mismatch first second decl ppf err
| Constructor_mismatch (c1, c2, err) ->
pr
"@[<hv>Constructors do not match:@;<1 2>%a@ is not compatible with:\
@;<1 2>%a@ %a"
Printtyp.constructor c1
Printtyp.constructor c2
(report_constructor_mismatch first second decl) err
| Constructor_names (n, name1, name2) ->
pr "Constructors number %i have different names, %s and %s."
n (Ident.name name1) (Ident.name name2)
pr "%i%s constructors have different names, %s and %s."
n (Misc.suffix n) (Ident.name name1) (Ident.name name2)
| Constructor_missing (ord, s) ->
pr "The constructor %s is only present in %s %s."
(Ident.name s) (choose ord first second) decl
@ -220,8 +245,12 @@ let report_extension_constructor_mismatch first second decl ppf err =
let pr fmt = Format.fprintf ppf fmt in
match (err : extension_constructor_mismatch) with
| Constructor_privacy -> pr "A private type would be revealed."
| Constructor_mismatch err ->
report_constructor_mismatch first second decl ppf err
| Constructor_mismatch (id, ext1, ext2, err) ->
pr "@[<hv>Constructors do not match:@;<1 2>%a@ is not compatible with:\
@;<1 2>%a@ %a@]"
(Printtyp.extension_only_constructor id) ext1
(Printtyp.extension_only_constructor id) ext2
(report_constructor_mismatch first second decl) err
let report_type_mismatch0 first second decl ppf err =
let pr fmt = Format.fprintf ppf fmt in
@ -245,31 +274,32 @@ let report_type_mismatch first second decl ppf err =
if err = Manifest then () else
Format.fprintf ppf "@ %a" (report_type_mismatch0 first second decl) err
let rec compare_constructor_arguments ~loc env cstr params1 params2 arg1 arg2 =
let rec compare_constructor_arguments ~loc env params1 params2 arg1 arg2 =
match arg1, arg2 with
| Types.Cstr_tuple arg1, Types.Cstr_tuple arg2 ->
if List.length arg1 <> List.length arg2 then
Some (Arity cstr : constructor_mismatch)
Some (Arity : constructor_mismatch)
else if
(* Ctype.equal must be called on all arguments at once, cf. PR#7378 *)
Ctype.equal env true (params1 @ arg1) (params2 @ arg2)
then None else Some (Type cstr)
then None else Some Type
| Types.Cstr_record l1, Types.Cstr_record l2 ->
Option.map
(fun rec_err -> Inline_record rec_err)
(compare_records env ~loc params1 params2 0 l1 l2)
| Types.Cstr_record _, _ | _, Types.Cstr_record _ -> Some (Type cstr)
| Types.Cstr_record _, _ -> Some (Kind First : constructor_mismatch)
| _, Types.Cstr_record _ -> Some (Kind Second : constructor_mismatch)
and compare_constructors ~loc env cstr params1 params2 res1 res2 args1 args2 =
and compare_constructors ~loc env params1 params2 res1 res2 args1 args2 =
match res1, res2 with
| Some r1, Some r2 ->
if Ctype.equal env true [r1] [r2] then
compare_constructor_arguments ~loc env cstr [r1] [r2] args1 args2
else Some (Type cstr)
compare_constructor_arguments ~loc env [r1] [r2] args1 args2
else Some Type
| Some _, None -> Some (Explicit_return_type First)
| None, Some _ -> Some (Explicit_return_type Second)
| None, None ->
compare_constructor_arguments ~loc env cstr params1 params2 args1 args2
compare_constructor_arguments ~loc env params1 params2 args1 args2
and compare_variants ~loc env params1 params2 n
(cstrs1 : Types.constructor_declaration list)
@ -288,9 +318,10 @@ and compare_variants ~loc env params1 params2 n
loc
cd1.cd_attributes cd2.cd_attributes
(Ident.name cd1.cd_id);
match compare_constructors ~loc env cd1.cd_id params1 params2
match compare_constructors ~loc env params1 params2
cd1.cd_res cd2.cd_res cd1.cd_args cd2.cd_args with
| Some r -> Some (Constructor_mismatch r : variant_mismatch)
| Some r ->
Some ((Constructor_mismatch (cd1, cd2, r)) : variant_mismatch)
| None -> compare_variants ~loc env params1 params2 (n+1) rem1 rem2
end
@ -298,11 +329,13 @@ and compare_labels env params1 params2
(ld1 : Types.label_declaration)
(ld2 : Types.label_declaration) =
if ld1.ld_mutable <> ld2.ld_mutable
then Some (Mutability ld1.ld_id)
then
let ord = if ld1.ld_mutable = Asttypes.Mutable then First else Second in
Some (Mutability ord)
else
if Ctype.equal env true (ld1.ld_type::params1) (ld2.ld_type::params2)
then None
else Some (Type ld1.ld_id : label_mismatch)
else Some (Type : label_mismatch)
and compare_records ~loc env params1 params2 n
(labels1 : Types.label_declaration list)
@ -322,7 +355,7 @@ and compare_records ~loc env params1 params2 n
ld1.ld_attributes ld2.ld_attributes
(Ident.name ld1.ld_id);
match compare_labels env params1 params2 ld1 ld2 with
| Some r -> Some (Label_mismatch r)
| Some r -> Some (Label_mismatch (ld1, ld2, r))
(* add arguments to the parameters, cf. PR#7378 *)
| None -> compare_records ~loc env
(ld1.ld_type::params1) (ld2.ld_type::params2)
@ -456,15 +489,15 @@ let extension_constructors ~loc env ~mark id ext1 ext2 =
in
if not (Ctype.equal env true (ty1 :: ext1.ext_type_params)
(ty2 :: ext2.ext_type_params))
then Some (Constructor_mismatch (Type id))
then Some (Constructor_mismatch (id, ext1, ext2, Type))
else
let r =
compare_constructors ~loc env id ext1.ext_type_params ext2.ext_type_params
compare_constructors ~loc env ext1.ext_type_params ext2.ext_type_params
ext1.ext_ret_type ext2.ext_ret_type
ext1.ext_args ext2.ext_args
in
match r with
| Some r -> Some (Constructor_mismatch r)
| Some r -> Some (Constructor_mismatch (id, ext1, ext2, r))
| None -> match ext1.ext_private, ext2.ext_private with
Private, Public -> Some Constructor_privacy
| _, _ -> None

20
typing/includecore.mli
View File

@ -23,29 +23,35 @@ exception Dont_match
type position = Ctype.Unification_trace.position = First | Second
type label_mismatch =
| Type of Ident.t
| Mutability of Ident.t
| Type
| Mutability of position
type record_mismatch =
| Label_mismatch of label_mismatch
| Label_mismatch of label_declaration * label_declaration * label_mismatch
| Label_names of int * Ident.t * Ident.t
| Label_missing of position * Ident.t
| Unboxed_float_representation of position
type constructor_mismatch =
| Type of Ident.t
| Arity of Ident.t
| Type
| Arity
| Inline_record of record_mismatch
| Kind of position
| Explicit_return_type of position
type variant_mismatch =
| Constructor_mismatch of constructor_mismatch
| Constructor_mismatch of constructor_declaration
* constructor_declaration
* constructor_mismatch
| Constructor_names of int * Ident.t * Ident.t
| Constructor_missing of position * Ident.t
type extension_constructor_mismatch =
| Constructor_privacy
| Constructor_mismatch of constructor_mismatch
| Constructor_mismatch of Ident.t
* extension_constructor
* extension_constructor
* constructor_mismatch
type type_mismatch =
| Arity

3
typing/oprint.ml
View File

@ -391,6 +391,8 @@ and print_out_label ppf (name, mut, arg) =
fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name
print_out_type arg
let out_label = ref print_out_label
let out_type = ref print_out_type
(* Class types *)
@ -704,6 +706,7 @@ and print_out_type_extension ppf te =
(print_list print_out_constr (fun ppf -> fprintf ppf "@ | "))
te.otyext_constructors
let out_constr = ref print_out_constr
let _ = out_module_type := print_out_module_type
let _ = out_signature := print_out_signature
let _ = out_sig_item := print_out_sig_item

3
typing/oprint.mli
View File

@ -18,7 +18,10 @@ open Outcometree
val out_ident : (formatter -> out_ident -> unit) ref
val out_value : (formatter -> out_value -> unit) ref
val out_label : (formatter -> string * bool * out_type -> unit) ref
val out_type : (formatter -> out_type -> unit) ref
val out_constr :
(formatter -> string * out_type list * out_type option -> unit) ref
val out_class_type : (formatter -> out_class_type -> unit) ref
val out_module_type : (formatter -> out_module_type -> unit) ref
val out_sig_item : (formatter -> out_sig_item -> unit) ref

37
typing/printtyp.ml
View File

@ -1221,6 +1221,10 @@ and tree_of_constructor cd =
and tree_of_label l =
(Ident.name l.ld_id, l.ld_mutable = Mutable, tree_of_typexp false l.ld_type)
let constructor ppf c = !Oprint.out_constr ppf (tree_of_constructor c)
let label ppf l = !Oprint.out_label ppf (tree_of_label l)
let tree_of_type_declaration id decl rs =
Osig_type (tree_of_type_decl id decl, tree_of_rec rs)
@ -1233,6 +1237,17 @@ let constructor_arguments ppf a =
(* Print an extension declaration *)
let extension_constructor_args_and_ret_type_subtree ext_args ext_ret_type =
match ext_ret_type with
| None -> (tree_of_constructor_arguments ext_args, None)
| Some res ->
let nm = !names in
names := [];
let ret = tree_of_typexp false res in
let args = tree_of_constructor_arguments ext_args in
names := nm;
(args, Some ret)
let tree_of_extension_constructor id ext es =
reset_except_context ();
let ty_name = Path.name ext.ext_type_path in
@ -1252,15 +1267,9 @@ let tree_of_extension_constructor id ext es =
in
let name = Ident.name id in
let args, ret =
match ext.ext_ret_type with
| None -> (tree_of_constructor_arguments ext.ext_args, None)
| Some res ->
let nm = !names in
names := [];
let ret = tree_of_typexp false res in
let args = tree_of_constructor_arguments ext.ext_args in
names := nm;
(args, Some ret)
extension_constructor_args_and_ret_type_subtree
ext.ext_args
ext.ext_ret_type
in
let ext =
{ oext_name = name;
@ -1281,6 +1290,16 @@ let tree_of_extension_constructor id ext es =
let extension_constructor id ppf ext =
!Oprint.out_sig_item ppf (tree_of_extension_constructor id ext Text_first)
let extension_only_constructor id ppf ext =
let name = Ident.name id in
let args, ret =
extension_constructor_args_and_ret_type_subtree
ext.ext_args
ext.ext_ret_type
in
Format.fprintf ppf "@[<hv>%a@]"
!Oprint.out_constr (name, args, ret)
(* Print a value declaration *)
let tree_of_value_description id decl =

7
typing/printtyp.mli
View File

@ -94,6 +94,11 @@ val type_scheme_max: ?b_reset_names: bool ->
(* End Maxence *)
val tree_of_value_description: Ident.t -> value_description -> out_sig_item
val value_description: Ident.t -> formatter -> value_description -> unit
val tree_of_label : label_declaration -> string * bool * out_type
val label : formatter -> label_declaration -> unit
val tree_of_constructor :
constructor_declaration -> string * out_type list * out_type option
val constructor : formatter -> constructor_declaration -> unit
val tree_of_type_declaration:
Ident.t -> type_declaration -> rec_status -> out_sig_item
val type_declaration: Ident.t -> formatter -> type_declaration -> unit
@ -101,6 +106,8 @@ val tree_of_extension_constructor:
Ident.t -> extension_constructor -> ext_status -> out_sig_item
val extension_constructor:
Ident.t -> formatter -> extension_constructor -> unit
val extension_only_constructor:
Ident.t -> formatter -> extension_constructor -> unit
val tree_of_module:
Ident.t -> ?ellipsis:bool -> module_type -> rec_status -> out_sig_item
val modtype: formatter -> module_type -> unit

8
typing/typedecl.ml
View File

@ -1746,14 +1746,6 @@ let report_error ppf = function
| false, true -> inj ^ "contravariant"
| false, false -> if inj = "" then "unrestricted" else inj
in
let suffix n =
let teen = (n mod 100)/10 = 1 in
match n mod 10 with
| 1 when not teen -> "st"
| 2 when not teen -> "nd"
| 3 when not teen -> "rd"
| _ -> "th"
in
(* FIXME: this test below is horrible, use a proper variant *)
if n = -1 then
fprintf ppf "@[%s@ %s@ It"

7
utils/misc.ml
View File

@ -862,6 +862,13 @@ let print_if ppf flag printer arg =
if !flag then Format.fprintf ppf "%a@." printer arg;
arg
let suffix n =
let teen = (n mod 100)/10 = 1 in
match n mod 10 with
| 1 when not teen -> "st"
| 2 when not teen -> "nd"
| 3 when not teen -> "rd"
| _ -> "th"
type filepath = string
type modname = string

1
utils/misc.mli
View File

@ -456,6 +456,7 @@ val print_if :
Format.formatter -> bool ref -> (Format.formatter -> 'a -> unit) -> 'a -> 'a
(** [print_if ppf flag fmt x] prints [x] with [fmt] on [ppf] if [b] is true. *)
val suffix : int -> string
type filepath = string
type modname = string