diff options
| author | Jacques Garrigue <garrigue at math.nagoya-u.ac.jp> | 2013-01-29 14:21:12 +0000 |
|---|---|---|
| committer | Jacques Garrigue <garrigue at math.nagoya-u.ac.jp> | 2013-01-29 14:21:12 +0000 |
| commit | 26e1ff7138c3e90e845fb278fc6283a166f1871f (patch) | |
| tree | d02a34c8baf030ed23102619fe541c888f85bf76 | |
| parent | d327f16c33093540f99738cf195d51b736f5581c (diff) | |
| parent | 1430e90e89240309b1aea3a7ddd0270bb16707b8 (diff) | |
| download | ocaml-26e1ff7138c3e90e845fb278fc6283a166f1871f.tar.gz | |
Merge short-paths into a fresh branch of trunk.short-paths-4.01
Also fix a bit unification and subtyping errors.
You now need the flag -short-path to activate short paths.
git-svn-id: http://caml.inria.fr/svn/ocaml/branches/short-paths-4.01@13285 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
67 files changed, 815 insertions, 806 deletions
diff --git a/driver/compile.ml b/driver/compile.ml index fe85673c30..0a4eb0ed34 100644 --- a/driver/compile.ml +++ b/driver/compile.ml @@ -87,15 +87,16 @@ let interface ppf sourcefile outputprefix = if !Clflags.dump_typedtree then fprintf ppf "%a@." Printtyped.interface tsg; let sg = tsg.sig_type in if !Clflags.print_types then - fprintf std_formatter "%a@." Printtyp.signature - (Typemod.simplify_signature sg); + Printtyp.wrap_printing_env initial_env (fun () -> + fprintf std_formatter "%a@." + Printtyp.signature (Typemod.simplify_signature sg)); ignore (Includemod.signatures initial_env sg sg); Typecore.force_delayed_checks (); Warnings.check_fatal (); if not !Clflags.print_types then begin let sg = Env.save_signature sg modulename (outputprefix ^ ".cmi") in Typemod.save_signature modulename tsg outputprefix sourcefile - initial_env sg ; + initial_env sg ; end; Pparse.remove_preprocessed inputfile with e -> @@ -125,7 +126,8 @@ let implementation ppf sourcefile outputprefix = ++ print_if ppf Clflags.dump_parsetree Printast.implementation ++ print_if ppf Clflags.dump_source Pprintast.structure ++ Typemod.type_implementation sourcefile outputprefix modulename env - ++ print_if ppf Clflags.dump_typedtree Printtyped.implementation_with_coercion); + ++ print_if ppf Clflags.dump_typedtree + Printtyped.implementation_with_coercion); Warnings.check_fatal (); Pparse.remove_preprocessed inputfile; Stypes.dump (Some (outputprefix ^ ".annot")); diff --git a/driver/errors.ml b/driver/errors.ml index de4900d0d4..d45af05632 100644 --- a/driver/errors.ml +++ b/driver/errors.ml @@ -39,19 +39,19 @@ let report_error ppf exn = fprintf ppf "In this program,@ variant constructors@ `%s and `%s@ \ have the same hash value.@ Change one of them." l l' - | Typecore.Error(loc, err) -> - Location.print_error ppf loc; Typecore.report_error ppf err - | Typetexp.Error(loc, err) -> - Location.print_error ppf loc; Typetexp.report_error ppf err + | Typecore.Error(loc, env, err) -> + Location.print_error ppf loc; Typecore.report_error env ppf err + | Typetexp.Error(loc, env, err) -> + Location.print_error ppf loc; Typetexp.report_error env ppf err | Typedecl.Error(loc, err) -> Location.print_error ppf loc; Typedecl.report_error ppf err - | Typeclass.Error(loc, err) -> - Location.print_error ppf loc; Typeclass.report_error ppf err + | Typeclass.Error(loc, env, err) -> + Location.print_error ppf loc; Typeclass.report_error env ppf err | Includemod.Error err -> Location.print_error_cur_file ppf; Includemod.report_error ppf err - | Typemod.Error(loc, err) -> - Location.print_error ppf loc; Typemod.report_error ppf err + | Typemod.Error(loc, env, err) -> + Location.print_error ppf loc; Typemod.report_error env ppf err | Translcore.Error(loc, err) -> Location.print_error ppf loc; Translcore.report_error ppf err | Translclass.Error(loc, err) -> diff --git a/driver/main.ml b/driver/main.ml index 8db8c71ead..984e509632 100644 --- a/driver/main.ml +++ b/driver/main.ml @@ -123,6 +123,7 @@ module Options = Main_args.Make_bytecomp_options (struct let _principal = set principal let _rectypes = set recursive_types let _runtime_variant s = runtime_variant := s + let _short_paths = unset real_paths let _strict_sequence = set strict_sequence let _thread = set use_threads let _vmthread = set use_vmthreads diff --git a/driver/main_args.ml b/driver/main_args.ml index 5356824973..ca381ee4cb 100644 --- a/driver/main_args.ml +++ b/driver/main_args.ml @@ -215,6 +215,10 @@ let mk_principal f = "-principal", Arg.Unit f, " Check principality of type inference" ;; +let mk_short_paths f = + "-short-paths", Arg.Unit f, " Shorten paths in types" +;; + let mk_rectypes f = "-rectypes", Arg.Unit f, " Allow arbitrary recursive types" ;; @@ -440,6 +444,7 @@ module type Bytecomp_options = sig val _pp : string -> unit val _ppx : string -> unit val _principal : unit -> unit + val _short_paths : unit -> unit val _rectypes : unit -> unit val _runtime_variant : string -> unit val _strict_sequence : unit -> unit @@ -481,6 +486,7 @@ module type Bytetop_options = sig val _nostdlib : unit -> unit val _ppx : string -> unit val _principal : unit -> unit + val _short_paths : unit -> unit val _rectypes : unit -> unit val _stdin: unit -> unit val _strict_sequence : unit -> unit @@ -535,6 +541,7 @@ module type Optcomp_options = sig val _pp : string -> unit val _ppx : string -> unit val _principal : unit -> unit + val _short_paths : unit -> unit val _rectypes : unit -> unit val _runtime_variant : string -> unit val _S : unit -> unit @@ -590,6 +597,7 @@ module type Opttop_options = sig val _nostdlib : unit -> unit val _ppx : string -> unit val _principal : unit -> unit + val _short_paths : unit -> unit val _rectypes : unit -> unit val _S : unit -> unit val _stdin : unit -> unit @@ -668,6 +676,7 @@ struct mk_pp F._pp; mk_ppx F._ppx; mk_principal F._principal; + mk_short_paths F._short_paths; mk_rectypes F._rectypes; mk_runtime_variant F._runtime_variant; mk_strict_sequence F._strict_sequence; @@ -713,6 +722,7 @@ struct mk_nostdlib F._nostdlib; mk_ppx F._ppx; mk_principal F._principal; + mk_short_paths F._short_paths; mk_rectypes F._rectypes; mk_stdin F._stdin; mk_strict_sequence F._strict_sequence; @@ -771,6 +781,7 @@ struct mk_pp F._pp; mk_ppx F._ppx; mk_principal F._principal; + mk_short_paths F._short_paths; mk_rectypes F._rectypes; mk_runtime_variant F._runtime_variant; mk_S F._S; @@ -828,6 +839,7 @@ module Make_opttop_options (F : Opttop_options) = struct mk_nostdlib F._nostdlib; mk_ppx F._ppx; mk_principal F._principal; + mk_short_paths F._short_paths; mk_rectypes F._rectypes; mk_S F._S; mk_stdin F._stdin; diff --git a/driver/main_args.mli b/driver/main_args.mli index 68688166cb..018271bdaf 100644 --- a/driver/main_args.mli +++ b/driver/main_args.mli @@ -44,6 +44,7 @@ module type Bytecomp_options = val _pp : string -> unit val _ppx : string -> unit val _principal : unit -> unit + val _short_paths : unit -> unit val _rectypes : unit -> unit val _runtime_variant : string -> unit val _strict_sequence : unit -> unit @@ -86,6 +87,7 @@ module type Bytetop_options = sig val _nostdlib : unit -> unit val _ppx : string -> unit val _principal : unit -> unit + val _short_paths : unit -> unit val _rectypes : unit -> unit val _stdin : unit -> unit val _strict_sequence : unit -> unit @@ -140,6 +142,7 @@ module type Optcomp_options = sig val _pp : string -> unit val _ppx : string -> unit val _principal : unit -> unit + val _short_paths : unit -> unit val _rectypes : unit -> unit val _runtime_variant : string -> unit val _S : unit -> unit @@ -195,6 +198,7 @@ module type Opttop_options = sig val _nostdlib : unit -> unit val _ppx : string -> unit val _principal : unit -> unit + val _short_paths : unit -> unit val _rectypes : unit -> unit val _S : unit -> unit val _stdin : unit -> unit diff --git a/driver/opterrors.ml b/driver/opterrors.ml index 90ba6727c5..38ed51bf9f 100644 --- a/driver/opterrors.ml +++ b/driver/opterrors.ml @@ -38,19 +38,19 @@ let report_error ppf exn = fprintf ppf "In this program,@ variant constructors@ `%s and `%s@ \ have the same hash value.@ Change one of them." l l' - | Typecore.Error(loc, err) -> - Location.print_error ppf loc; Typecore.report_error ppf err - | Typetexp.Error(loc, err) -> - Location.print_error ppf loc; Typetexp.report_error ppf err + | Typecore.Error(loc, env, err) -> + Location.print_error ppf loc; Typecore.report_error env ppf err + | Typetexp.Error(loc, env, err) -> + Location.print_error ppf loc; Typetexp.report_error env ppf err | Typedecl.Error(loc, err) -> Location.print_error ppf loc; Typedecl.report_error ppf err - | Typeclass.Error(loc, err) -> - Location.print_error ppf loc; Typeclass.report_error ppf err + | Typeclass.Error(loc, env, err) -> + Location.print_error ppf loc; Typeclass.report_error env ppf err | Includemod.Error err -> Location.print_error_cur_file ppf; Includemod.report_error ppf err - | Typemod.Error(loc, err) -> - Location.print_error ppf loc; Typemod.report_error ppf err + | Typemod.Error(loc, env, err) -> + Location.print_error ppf loc; Typemod.report_error env ppf err | Translcore.Error(loc, err) -> Location.print_error ppf loc; Translcore.report_error ppf err | Translclass.Error(loc, err) -> diff --git a/driver/optmain.ml b/driver/optmain.ml index 90e1cd679f..13b6000c70 100644 --- a/driver/optmain.ml +++ b/driver/optmain.ml @@ -132,6 +132,7 @@ module Options = Main_args.Make_optcomp_options (struct let _pp s = preprocessor := Some s let _ppx s = ppx := s :: !ppx let _principal = set principal + let _short_paths = clear real_paths let _rectypes = set recursive_types let _runtime_variant s = runtime_variant := s let _strict_sequence = set strict_sequence diff --git a/ocamldoc/odoc_analyse.ml b/ocamldoc/odoc_analyse.ml index 0bffda53c2..572e94fff9 100644 --- a/ocamldoc/odoc_analyse.ml +++ b/ocamldoc/odoc_analyse.ml @@ -124,24 +124,24 @@ let process_error exn = fprintf ppf "In this program,@ variant constructors@ `%s and `%s@ \ have the same hash value." l l' - | Typecore.Error(loc, err) -> - Location.print_error ppf loc; Typecore.report_error ppf err - | Typetexp.Error(loc, err) -> - Location.print_error ppf loc; Typetexp.report_error ppf err + | Typecore.Error(loc, env, err) -> + Location.print_error ppf loc; Typecore.report_error env ppf err + | Typetexp.Error(loc, env, err) -> + Location.print_error ppf loc; Typetexp.report_error env ppf err | Typedecl.Error(loc, err) -> Location.print_error ppf loc; Typedecl.report_error ppf err | Includemod.Error err -> Location.print_error_cur_file ppf; Includemod.report_error ppf err - | Typemod.Error(loc, err) -> - Location.print_error ppf loc; Typemod.report_error ppf err + | Typemod.Error(loc, env, err) -> + Location.print_error ppf loc; Typemod.report_error env ppf err | Translcore.Error(loc, err) -> Location.print_error ppf loc; Translcore.report_error ppf err | Sys_error msg -> Location.print_error_cur_file ppf; fprintf ppf "I/O error: %s" msg - | Typeclass.Error(loc, err) -> - Location.print_error ppf loc; Typeclass.report_error ppf err + | Typeclass.Error(loc, env, err) -> + Location.print_error ppf loc; Typeclass.report_error env ppf err | Translclass.Error(loc, err) -> Location.print_error ppf loc; Translclass.report_error ppf err | Warnings.Errors (n) -> diff --git a/otherlibs/labltk/browser/searchid.ml b/otherlibs/labltk/browser/searchid.ml index ab66f0f030..0cad8ffc7a 100644 --- a/otherlibs/labltk/browser/searchid.ml +++ b/otherlibs/labltk/browser/searchid.ml @@ -294,11 +294,11 @@ let search_string_type text ~mode = end in try (Typemod.transl_signature env sexp).sig_type with Env.Error err -> [] - | Typemod.Error (l,_) -> + | Typemod.Error (l,_,_) -> let start_c = l.loc_start.Lexing.pos_cnum in let end_c = l.loc_end.Lexing.pos_cnum in raise (Error (start_c - 8, end_c - 8)) - | Typetexp.Error (l,_) -> + | Typetexp.Error (l,_,_) -> let start_c = l.loc_start.Lexing.pos_cnum in let end_c = l.loc_end.Lexing.pos_cnum in raise (Error (start_c - 8, end_c - 8)) diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml index 67c467f7c5..6ba813c4cb 100644 --- a/otherlibs/labltk/browser/searchpos.ml +++ b/otherlibs/labltk/browser/searchpos.ml @@ -385,7 +385,8 @@ let rec view_signature ?title ?path ?(env = !start_env) ?(detach=false) sign = tl, tw, finish in Format.set_max_boxes 100; - Printtyp.signature Format.std_formatter sign; + Printtyp.wrap_printing_env env + (fun () -> Printtyp.signature Format.std_formatter sign); finish (); Lexical.init_tags tw; Lexical.tag tw; @@ -526,16 +527,18 @@ and view_decl_menu lid ~kind ~env ~parent = Format.set_formatter_output_functions buf#out (fun () -> ()); Format.set_margin 60; Format.open_hbox (); - if kind = `Type then - Printtyp.type_declaration - (ident_of_path path ~default:"t") - Format.std_formatter - (find_type path env) - else - Printtyp.modtype_declaration - (ident_of_path path ~default:"S") - Format.std_formatter - (find_modtype path env); + Printtyp.wrap_printing_env env begin fun () -> + if kind = `Type then + Printtyp.type_declaration + (ident_of_path path ~default:"t") + Format.std_formatter + (find_type path env) + else + Printtyp.modtype_declaration + (ident_of_path path ~default:"S") + Format.std_formatter + (find_modtype path env) + end; Format.close_box (); Format.print_flush (); Format.set_formatter_output_functions fo ff; Format.set_margin margin; @@ -626,7 +629,8 @@ let view_type_menu kind ~env ~parent = Format.open_hbox (); Printtyp.reset (); Printtyp.mark_loops ty; - Printtyp.type_expr Format.std_formatter ty; + Printtyp.wrap_printing_env env + (fun () -> Printtyp.type_expr Format.std_formatter ty); Format.close_box (); Format.print_flush (); Format.set_formatter_output_functions fo ff; Format.set_margin margin; diff --git a/otherlibs/labltk/browser/typecheck.ml b/otherlibs/labltk/browser/typecheck.ml index 9859965d81..286f6bc953 100644 --- a/otherlibs/labltk/browser/typecheck.ml +++ b/otherlibs/labltk/browser/typecheck.ml @@ -138,16 +138,16 @@ let f txt = | Syntaxerr.Error err -> Syntaxerr.report_error Format.std_formatter err; Syntaxerr.location_of_error err - | Typecore.Error (l,err) -> - Typecore.report_error Format.std_formatter err; l - | Typeclass.Error (l,err) -> - Typeclass.report_error Format.std_formatter err; l + | Typecore.Error (l, env, err) -> + Typecore.report_error env Format.std_formatter err; l + | Typeclass.Error (l, env, err) -> + Typeclass.report_error env Format.std_formatter err; l | Typedecl.Error (l, err) -> Typedecl.report_error Format.std_formatter err; l - | Typemod.Error (l,err) -> - Typemod.report_error Format.std_formatter err; l - | Typetexp.Error (l,err) -> - Typetexp.report_error Format.std_formatter err; l + | Typemod.Error (l, env, err) -> + Typemod.report_error env Format.std_formatter err; l + | Typetexp.Error (l, env, err) -> + Typetexp.report_error env Format.std_formatter err; l | Includemod.Error errl -> Includemod.report_error Format.std_formatter errl; Location.none | Env.Error err -> diff --git a/testsuite/tests/typing-gadts/dynamic_frisch.ml.principal.reference b/testsuite/tests/typing-gadts/dynamic_frisch.ml.principal.reference index 5910bc646a..a894b22d8b 100644 --- a/testsuite/tests/typing-gadts/dynamic_frisch.ml.principal.reference +++ b/testsuite/tests/typing-gadts/dynamic_frisch.ml.principal.reference @@ -149,6 +149,7 @@ val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum (<fun>, <fun>) Error: This pattern matches values of type a * a vlist but a pattern was expected which matches values of type a#5 = ex#34 * ex#35 + Type a is not compatible with type ex#34 # type (_, _) ty = Int : (int, 'd) ty | String : (string, 'f) ty diff --git a/testsuite/tests/typing-gadts/dynamic_frisch.ml.reference b/testsuite/tests/typing-gadts/dynamic_frisch.ml.reference index 5910bc646a..a894b22d8b 100644 --- a/testsuite/tests/typing-gadts/dynamic_frisch.ml.reference +++ b/testsuite/tests/typing-gadts/dynamic_frisch.ml.reference @@ -149,6 +149,7 @@ val ty_abc : ([ `A of int | `B of string | `C ], 'e) ty = Sum (<fun>, <fun>) Error: This pattern matches values of type a * a vlist but a pattern was expected which matches values of type a#5 = ex#34 * ex#35 + Type a is not compatible with type ex#34 # type (_, _) ty = Int : (int, 'd) ty | String : (string, 'f) ty diff --git a/testsuite/tests/typing-gadts/test.ml.principal.reference b/testsuite/tests/typing-gadts/test.ml.principal.reference index dbad727023..0a59d045ff 100644 --- a/testsuite/tests/typing-gadts/test.ml.principal.reference +++ b/testsuite/tests/typing-gadts/test.ml.principal.reference @@ -62,6 +62,7 @@ Error: Recursive local constraint when unifying (s, s) t with (s, s * s) t ^^^^^^^^ Error: This pattern matches values of type int t but a pattern was expected which matches values of type s t + Type int is not compatible with type s # module Polymorphic_variants : sig type _ t = IntLit : int -> int t | BoolLit : bool -> bool t @@ -274,6 +275,7 @@ val f : 'a ty -> 'a t -> int = <fun> ^^ Error: This expression has type (a, a) eq but an expression was expected of type (a, b) eq + Type a is not compatible with type b # val f : ('a M.t * 'a, 'b M.t * 'b) eq -> ('a, 'b) eq = <fun> # val f : ('a * 'a M.t, 'b * 'b M.t) eq -> ('a, 'b) eq = <fun> # type _ t = V1 : [ `A | `B ] t | V2 : [ `C | `D ] t @@ -295,6 +297,7 @@ Error: This expression has type t = < foo : int; .. > but an expression was expected of type < bar : int; foo : int > Type ex#19 = < bar : int; .. > is not compatible with type < bar : int > + The first object type has an abstract row, it cannot be closed # Characters 98-99: (x:<foo:int;bar:int;..>) ^ diff --git a/testsuite/tests/typing-gadts/test.ml.reference b/testsuite/tests/typing-gadts/test.ml.reference index af8047775d..a226a2a493 100644 --- a/testsuite/tests/typing-gadts/test.ml.reference +++ b/testsuite/tests/typing-gadts/test.ml.reference @@ -62,6 +62,7 @@ Error: Recursive local constraint when unifying (s, s) t with (s, s * s) t ^^^^^^^^ Error: This pattern matches values of type int t but a pattern was expected which matches values of type s t + Type int is not compatible with type s # module Polymorphic_variants : sig type _ t = IntLit : int -> int t | BoolLit : bool -> bool t @@ -260,6 +261,7 @@ val f : 'a ty -> 'a t -> int = <fun> ^^ Error: This expression has type (a, a) eq but an expression was expected of type (a, b) eq + Type a is not compatible with type b # val f : ('a M.t * 'a, 'b M.t * 'b) eq -> ('a, 'b) eq = <fun> # val f : ('a * 'a M.t, 'b * 'b M.t) eq -> ('a, 'b) eq = <fun> # type _ t = V1 : [ `A | `B ] t | V2 : [ `C | `D ] t @@ -281,6 +283,7 @@ Error: This expression has type t = < foo : int; .. > but an expression was expected of type < bar : int; foo : int > Type ex#19 = < bar : int; .. > is not compatible with type < bar : int > + The first object type has an abstract row, it cannot be closed # Characters 98-99: (x:<foo:int;bar:int;..>) ^ diff --git a/testsuite/tests/typing-misc/Makefile b/testsuite/tests/typing-misc/Makefile deleted file mode 100644 index c9433b2ecb..0000000000 --- a/testsuite/tests/typing-misc/Makefile +++ /dev/null @@ -1,15 +0,0 @@ -######################################################################### -# # -# OCaml # -# # -# Xavier Clerc, SED, INRIA Rocquencourt # -# # -# Copyright 2010 Institut National de Recherche en Informatique et # -# en Automatique. All rights reserved. This file is distributed # -# under the terms of the Q Public License version 1.0. # -# # -######################################################################### - -BASEDIR=../.. -include $(BASEDIR)/makefiles/Makefile.toplevel -include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/typing-misc/constraints.ml b/testsuite/tests/typing-misc/constraints.ml deleted file mode 100644 index 5408ca2c1b..0000000000 --- a/testsuite/tests/typing-misc/constraints.ml +++ /dev/null @@ -1,16 +0,0 @@ -type 'a t = [`A of 'a t t] as 'a;; (* fails *) - -type 'a t = [`A of 'a t t];; (* fails *) - -type 'a t = [`A of 'a t t] constraint 'a = 'a t;; - -type 'a t = [`A of 'a t] constraint 'a = 'a t;; - -type 'a t = [`A of 'a] as 'a;; - -type 'a v = [`A of u v] constraint 'a = t and t = u and u = t;; (* fails *) - -type 'a t = 'a;; -let f (x : 'a t as 'a) = ();; (* fails *) - -let f (x : 'a t) (y : 'a) = x = y;; diff --git a/testsuite/tests/typing-misc/constraints.ml.reference b/testsuite/tests/typing-misc/constraints.ml.reference deleted file mode 100644 index fe52044002..0000000000 --- a/testsuite/tests/typing-misc/constraints.ml.reference +++ /dev/null @@ -1,29 +0,0 @@ - -# Characters 12-32: - type 'a t = [`A of 'a t t] as 'a;; (* fails *) - ^^^^^^^^^^^^^^^^^^^^ -Error: Constraints are not satisfied in this type. - Type - [ `A of 'a ] t t as 'a - should be an instance of - ([ `A of 'b t t ] as 'b) t -# Characters 5-27: - type 'a t = [`A of 'a t t];; (* fails *) - ^^^^^^^^^^^^^^^^^^^^^^ -Error: In the definition of t, type 'a t t should be 'a t -# type 'a t = [ `A of 'a t t ] constraint 'a = 'a t -# type 'a t = [ `A of 'a t ] constraint 'a = 'a t -# type 'a t = 'a constraint 'a = [ `A of 'a ] -# Characters 47-52: - type 'a v = [`A of u v] constraint 'a = t and t = u and u = t;; (* fails *) - ^^^^^ -Error: The type abbreviation t is cyclic -# type 'a t = 'a -# Characters 11-21: - let f (x : 'a t as 'a) = ();; (* fails *) - ^^^^^^^^^^ -Error: This alias is bound to type 'a t = 'a - but is used as an instance of type 'a - The type variable 'a occurs inside 'a -# val f : 'a t -> 'a -> bool = <fun> -# diff --git a/testsuite/tests/typing-misc/labels.ml b/testsuite/tests/typing-misc/labels.ml deleted file mode 100644 index b0f0229a6b..0000000000 --- a/testsuite/tests/typing-misc/labels.ml +++ /dev/null @@ -1,4 +0,0 @@ -(* PR#5835 *) - -let f ~x = x + 1;; -f ?x:0;; diff --git a/testsuite/tests/typing-misc/labels.ml.principal.reference b/testsuite/tests/typing-misc/labels.ml.principal.reference deleted file mode 100644 index 4dd851f1f9..0000000000 --- a/testsuite/tests/typing-misc/labels.ml.principal.reference +++ /dev/null @@ -1,8 +0,0 @@ - -# val f : x:int -> int = <fun> -# Characters 5-6: - f ?x:0;; - ^ -Error: The function applied to this argument has type x:int -> int -This argument cannot be applied with label ?x -# diff --git a/testsuite/tests/typing-misc/labels.ml.reference b/testsuite/tests/typing-misc/labels.ml.reference deleted file mode 100644 index 4dd851f1f9..0000000000 --- a/testsuite/tests/typing-misc/labels.ml.reference +++ /dev/null @@ -1,8 +0,0 @@ - -# val f : x:int -> int = <fun> -# Characters 5-6: - f ?x:0;; - ^ -Error: The function applied to this argument has type x:int -> int -This argument cannot be applied with label ?x -# diff --git a/testsuite/tests/typing-misc/occur_check.ml b/testsuite/tests/typing-misc/occur_check.ml deleted file mode 100644 index 5509b6f5ff..0000000000 --- a/testsuite/tests/typing-misc/occur_check.ml +++ /dev/null @@ -1,5 +0,0 @@ -(* PR#5907 *) - -type 'a t = 'a;; -let f (g : 'a list -> 'a t -> 'a) s = g s s;; -let f (g : 'a * 'b -> 'a t -> 'a) s = g s s;; diff --git a/testsuite/tests/typing-misc/occur_check.ml.reference b/testsuite/tests/typing-misc/occur_check.ml.reference deleted file mode 100644 index 865c7d6441..0000000000 --- a/testsuite/tests/typing-misc/occur_check.ml.reference +++ /dev/null @@ -1,15 +0,0 @@ - -# type 'a t = 'a -# Characters 42-43: - let f (g : 'a list -> 'a t -> 'a) s = g s s;; - ^ -Error: This expression has type 'a list - but an expression was expected of type 'a t = 'a - The type variable 'a occurs inside 'a list -# Characters 42-43: - let f (g : 'a * 'b -> 'a t -> 'a) s = g s s;; - ^ -Error: This expression has type 'a * 'b - but an expression was expected of type 'a t = 'a - The type variable 'a occurs inside 'a * 'b -# diff --git a/testsuite/tests/typing-misc/polyvars.ml b/testsuite/tests/typing-misc/polyvars.ml deleted file mode 100644 index 00dacf7540..0000000000 --- a/testsuite/tests/typing-misc/polyvars.ml +++ /dev/null @@ -1,7 +0,0 @@ -type ab = [ `A | `B ];; -let f (x : [`A]) = match x with #ab -> 1;; -let f x = ignore (match x with #ab -> 1); ignore (x : [`A]);; -let f x = ignore (match x with `A|`B -> 1); ignore (x : [`A]);; - -let f (x : [< `A | `B]) = match x with `A | `B | `C -> 0;; (* warn *) -let f (x : [`A | `B]) = match x with `A | `B | `C -> 0;; (* fail *) diff --git a/testsuite/tests/typing-misc/polyvars.ml.principal.reference b/testsuite/tests/typing-misc/polyvars.ml.principal.reference deleted file mode 100644 index bc0741abb6..0000000000 --- a/testsuite/tests/typing-misc/polyvars.ml.principal.reference +++ /dev/null @@ -1,32 +0,0 @@ - -# type ab = [ `A | `B ] -# Characters 32-35: - let f (x : [`A]) = match x with #ab -> 1;; - ^^^ -Error: This pattern matches values of type [? `A | `B ] - but a pattern was expected which matches values of type [ `A ] - The second variant type does not allow tag(s) `B -# Characters 31-34: - let f x = ignore (match x with #ab -> 1); ignore (x : [`A]);; - ^^^ -Error: This pattern matches values of type [? `B ] - but a pattern was expected which matches values of type [ `A ] - Types for tag `B are incompatible -# Characters 34-36: - let f x = ignore (match x with `A|`B -> 1); ignore (x : [`A]);; - ^^ -Error: This pattern matches values of type [? `B ] - but a pattern was expected which matches values of type [ `A ] - Types for tag `B are incompatible -# Characters 50-52: - let f (x : [< `A | `B]) = match x with `A | `B | `C -> 0;; (* warn *) - ^^ -Warning 12: this sub-pattern is unused. -val f : [< `A | `B ] -> int = <fun> -# Characters 47-49: - let f (x : [`A | `B]) = match x with `A | `B | `C -> 0;; (* fail *) - ^^ -Error: This pattern matches values of type [? `C ] - but a pattern was expected which matches values of type [ `A | `B ] - The second variant type does not allow tag(s) `C -# diff --git a/testsuite/tests/typing-misc/polyvars.ml.reference b/testsuite/tests/typing-misc/polyvars.ml.reference deleted file mode 100644 index 27c4cd4304..0000000000 --- a/testsuite/tests/typing-misc/polyvars.ml.reference +++ /dev/null @@ -1,32 +0,0 @@ - -# type ab = [ `A | `B ] -# Characters 32-35: - let f (x : [`A]) = match x with #ab -> 1;; - ^^^ -Error: This pattern matches values of type [? `A | `B ] - but a pattern was expected which matches values of type [ `A ] - The second variant type does not allow tag(s) `B -# Characters 31-34: - let f x = ignore (match x with #ab -> 1); ignore (x : [`A]);; - ^^^ -Error: This pattern matches values of type [? `B ] - but a pattern was expected which matches values of type [ `A ] - The second variant type does not allow tag(s) `B -# Characters 34-36: - let f x = ignore (match x with `A|`B -> 1); ignore (x : [`A]);; - ^^ -Error: This pattern matches values of type [? `B ] - but a pattern was expected which matches values of type [ `A ] - The second variant type does not allow tag(s) `B -# Characters 50-52: - let f (x : [< `A | `B]) = match x with `A | `B | `C -> 0;; (* warn *) - ^^ -Warning 12: this sub-pattern is unused. -val f : [< `A | `B ] -> int = <fun> -# Characters 47-49: - let f (x : [`A | `B]) = match x with `A | `B | `C -> 0;; (* fail *) - ^^ -Error: This pattern matches values of type [? `C ] - but a pattern was expected which matches values of type [ `A | `B ] - The second variant type does not allow tag(s) `C -# diff --git a/testsuite/tests/typing-misc/records.ml b/testsuite/tests/typing-misc/records.ml deleted file mode 100644 index ae296cf125..0000000000 --- a/testsuite/tests/typing-misc/records.ml +++ /dev/null @@ -1,38 +0,0 @@ -(* undefined labels *) -type t = {x:int;y:int};; -{x=3;z=2};; -fun {x=3;z=2} -> ();; - -(* mixed labels *) -{x=3; contents=2};; - -(* private types *) -type u = private {mutable u:int};; -{u=3};; -fun x -> x.u <- 3;; - -(* Punning and abbreviations *) -module M = struct - type t = {x: int; y: int} -end;; - -let f {M.x; y} = x+y;; -let r = {M.x=1; y=2};; -let z = f r;; - -(* messages *) -type foo = { mutable y:int };; -let f (r: int) = r.y <- 3;; - -(* bugs *) -type foo = { y: int; z: int };; -type bar = { x: int };; -let f (r: bar) = ({ r with z = 3 } : foo) - -type foo = { x: int };; -let r : foo = { ZZZ.x = 2 };; - -(ZZZ.X : int option);; - -(* PR#5865 *) -let f (x : Complex.t) = x.Complex.z;; diff --git a/testsuite/tests/typing-misc/records.ml.principal.reference b/testsuite/tests/typing-misc/records.ml.principal.reference deleted file mode 100644 index f084d039db..0000000000 --- a/testsuite/tests/typing-misc/records.ml.principal.reference +++ /dev/null @@ -1,54 +0,0 @@ - -# type t = { x : int; y : int; } -# Characters 5-6: - {x=3;z=2};; - ^ -Error: Unbound record field z -# Characters 9-10: - fun {x=3;z=2} -> ();; - ^ -Error: Unbound record field z -# Characters 26-34: - {x=3; contents=2};; - ^^^^^^^^ -Error: The record field contents belongs to the type 'a ref - but is mixed here with fields of type t -# type u = private { mutable u : int; } -# Characters 0-5: - {u=3};; - ^^^^^ -Error: Cannot create values of the private type u -# Characters 11-12: - fun x -> x.u <- 3;; - ^ -Error: Cannot assign field u of the private type u -# module M : sig type t = { x : int; y : int; } end -# val f : M.t -> int = <fun> -# val r : M.t = {M.x = 1; y = 2} -# val z : int = 3 -# type foo = { mutable y : int; } -# Characters 17-18: - let f (r: int) = r.y <- 3;; - ^ -Error: This expression has type int but an expression was expected of type - foo -# type foo = { y : int; z : int; } -# type bar = { x : int; } -# Characters 20-21: - let f (r: bar) = ({ r with z = 3 } : foo) - ^ -Error: This expression has type bar but an expression was expected of type - foo -# Characters 16-21: - let r : foo = { ZZZ.x = 2 };; - ^^^^^ -Error: Unbound module ZZZ -# Characters 2-7: - (ZZZ.X : int option);; - ^^^^^ -Error: Unbound module ZZZ -# Characters 41-50: - let f (x : Complex.t) = x.Complex.z;; - ^^^^^^^^^ -Error: Unbound record field Complex.z -# diff --git a/testsuite/tests/typing-misc/records.ml.reference b/testsuite/tests/typing-misc/records.ml.reference deleted file mode 100644 index f084d039db..0000000000 --- a/testsuite/tests/typing-misc/records.ml.reference +++ /dev/null @@ -1,54 +0,0 @@ - -# type t = { x : int; y : int; } -# Characters 5-6: - {x=3;z=2};; - ^ -Error: Unbound record field z -# Characters 9-10: - fun {x=3;z=2} -> ();; - ^ -Error: Unbound record field z -# Characters 26-34: - {x=3; contents=2};; - ^^^^^^^^ -Error: The record field contents belongs to the type 'a ref - but is mixed here with fields of type t -# type u = private { mutable u : int; } -# Characters 0-5: - {u=3};; - ^^^^^ -Error: Cannot create values of the private type u -# Characters 11-12: - fun x -> x.u <- 3;; - ^ -Error: Cannot assign field u of the private type u -# module M : sig type t = { x : int; y : int; } end -# val f : M.t -> int = <fun> -# val r : M.t = {M.x = 1; y = 2} -# val z : int = 3 -# type foo = { mutable y : int; } -# Characters 17-18: - let f (r: int) = r.y <- 3;; - ^ -Error: This expression has type int but an expression was expected of type - foo -# type foo = { y : int; z : int; } -# type bar = { x : int; } -# Characters 20-21: - let f (r: bar) = ({ r with z = 3 } : foo) - ^ -Error: This expression has type bar but an expression was expected of type - foo -# Characters 16-21: - let r : foo = { ZZZ.x = 2 };; - ^^^^^ -Error: Unbound module ZZZ -# Characters 2-7: - (ZZZ.X : int option);; - ^^^^^ -Error: Unbound module ZZZ -# Characters 41-50: - let f (x : Complex.t) = x.Complex.z;; - ^^^^^^^^^ -Error: Unbound record field Complex.z -# diff --git a/testsuite/tests/typing-misc/short-paths.ml b/testsuite/tests/typing-misc/short-paths.ml new file mode 100644 index 0000000000..aa7e02d2f1 --- /dev/null +++ b/testsuite/tests/typing-misc/short-paths.ml @@ -0,0 +1,21 @@ +module Core = struct + module Int = struct + module T = struct + type t = int + let compare = compare + let (+) x y = x + y + end + include T + module Map = Map.Make(T) + end + + module Std = struct + module Int = Int + end +end + +open Core.Std + + +let x = Int.Map.empty +let y = x + x diff --git a/testsuite/tests/typing-objects/Exemples.ml.principal.reference b/testsuite/tests/typing-objects/Exemples.ml.principal.reference index d6f9d6df18..0b04607a21 100644 --- a/testsuite/tests/typing-objects/Exemples.ml.principal.reference +++ b/testsuite/tests/typing-objects/Exemples.ml.principal.reference @@ -93,7 +93,7 @@ Error: Type is not a subtype of point circle = < center : point; move : int -> unit; set_center : point -> unit > -Type point = point is not a subtype of color_point = color_point + Type point is not a subtype of color_point # Characters 9-55: fun x -> (x : color_point color_circle :> point circle);; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ @@ -104,7 +104,7 @@ Error: Type is not a subtype of point circle = < center : point; move : int -> unit; set_center : point -> unit > -Type point = point is not a subtype of color_point = color_point + Type point is not a subtype of color_point # class printable_point : int -> object @@ -215,10 +215,10 @@ Error: Type < leq : int_comparable2 -> bool; set_x : int -> unit; x : int > is not a subtype of int_comparable = < leq : int_comparable -> bool; x : int > -Type int_comparable = < leq : int_comparable -> bool; x : int > -is not a subtype of - int_comparable2 = - < leq : int_comparable2 -> bool; set_x : int -> unit; x : int > + Type int_comparable = < leq : int_comparable -> bool; x : int > + is not a subtype of + int_comparable2 = + < leq : int_comparable2 -> bool; set_x : int -> unit; x : int > # - : unit = () # class int_comparable3 : int -> diff --git a/testsuite/tests/typing-objects/Exemples.ml.reference b/testsuite/tests/typing-objects/Exemples.ml.reference index 128d1be70d..353f607cb5 100644 --- a/testsuite/tests/typing-objects/Exemples.ml.reference +++ b/testsuite/tests/typing-objects/Exemples.ml.reference @@ -93,7 +93,7 @@ Error: Type is not a subtype of point circle = < center : point; move : int -> unit; set_center : point -> unit > -Type point = point is not a subtype of color_point = color_point + Type point is not a subtype of color_point # Characters 9-55: fun x -> (x : color_point color_circle :> point circle);; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ @@ -104,7 +104,7 @@ Error: Type is not a subtype of point circle = < center : point; move : int -> unit; set_center : point -> unit > -Type point = point is not a subtype of color_point = color_point + Type point is not a subtype of color_point # class printable_point : int -> object @@ -215,10 +215,10 @@ Error: Type < leq : int_comparable2 -> bool; set_x : int -> unit; x : int > is not a subtype of int_comparable = < leq : int_comparable -> bool; x : int > -Type int_comparable = < leq : int_comparable -> bool; x : int > -is not a subtype of - int_comparable2 = - < leq : int_comparable2 -> bool; set_x : int -> unit; x : int > + Type int_comparable = < leq : int_comparable -> bool; x : int > + is not a subtype of + int_comparable2 = + < leq : int_comparable2 -> bool; set_x : int -> unit; x : int > # - : unit = () # class int_comparable3 : int -> diff --git a/testsuite/tests/typing-objects/Tests.ml.principal.reference b/testsuite/tests/typing-objects/Tests.ml.principal.reference index f938ff0b67..52f2a09282 100644 --- a/testsuite/tests/typing-objects/Tests.ml.principal.reference +++ b/testsuite/tests/typing-objects/Tests.ml.principal.reference @@ -254,10 +254,12 @@ Error: Multiple definition of the type name t. fun x -> (x : int -> bool :> 'a -> 'a);; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Type int -> bool is not a subtype of int -> int + Type bool is not a subtype of int # Characters 9-40: fun x -> (x : int -> bool :> int -> int);; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Type int -> bool is not a subtype of int -> int + Type bool is not a subtype of int # - : < > -> < > = <fun> # - : < .. > -> < > = <fun> # val x : '_a list ref = {contents = []} diff --git a/testsuite/tests/typing-objects/Tests.ml.reference b/testsuite/tests/typing-objects/Tests.ml.reference index 814eae33f0..038f3dd545 100644 --- a/testsuite/tests/typing-objects/Tests.ml.reference +++ b/testsuite/tests/typing-objects/Tests.ml.reference @@ -254,10 +254,12 @@ Error: Multiple definition of the type name t. fun x -> (x : int -> bool :> 'a -> 'a);; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Type int -> bool is not a subtype of int -> int + Type bool is not a subtype of int # Characters 9-40: fun x -> (x : int -> bool :> int -> int);; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Type int -> bool is not a subtype of int -> int + Type bool is not a subtype of int # - : < > -> < > = <fun> # - : < .. > -> < > = <fun> # val x : '_a list ref = {contents = []} diff --git a/testsuite/tests/typing-poly/poly.ml.principal.reference b/testsuite/tests/typing-poly/poly.ml.principal.reference index c489a509bb..f0b3dad708 100644 --- a/testsuite/tests/typing-poly/poly.ml.principal.reference +++ b/testsuite/tests/typing-poly/poly.ml.principal.reference @@ -454,6 +454,7 @@ Error: This expression has type < m : 'b. 'b * ('b * 'a) > as 'a :> <m : 'a. 'a -> ('a * 'foo)> as 'foo).. Error: Type < m : 'a. 'a -> ('a * (< m : 'c. 'c -> 'b as 'e > as 'd) as 'b) > is not a subtype of < m : 'a. 'a -> ('a * 'f as 'h) as 'g > as 'f + Type 'c. 'e is not a subtype of 'a. 'g # Characters 88-150: = struct let f (x : <m : 'a. 'a * ('a * 'foo)> as 'foo) = () end;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ @@ -512,6 +513,8 @@ Error: Type p = < x : p > is not a subtype of q = < x : p; .. > :> <m:'b. (<p:int;q:int;..> as 'b) -> int>).. Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of < m : 'b. (< p : int; q : int; .. > as 'b) -> int > + Type < p : int; q : int; .. > as 'c is not a subtype of + < p : int; .. > as 'd # val f2 : < m : 'a. (< p : < a : int >; .. > as 'a) -> int > -> < m : 'b. (< p : < a : int; b : int >; .. > as 'b) -> int > = <fun> @@ -520,12 +523,13 @@ Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of :> <m:'b. (<p:<a:int>;..> as 'b) -> int>).. Error: Type < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int > is not a subtype of < m : 'b. (< p : < a : int >; .. > as 'b) -> int > + Type < a : int > is not a subtype of < a : int; b : int > # Characters 11-55: let f4 x = (x : <p:<a:int;b:int>;..> :> <p:<a:int>;..>);; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Type < p : < a : int; b : int >; .. > is not a subtype of < p : < a : int >; .. > -The second object type has no method b + The second object type has no method b # val f5 : < m : 'a. [< `A of < p : int > ] as 'a > -> < m : 'b. [< `A of < > ] as 'b > = <fun> @@ -534,6 +538,7 @@ The second object type has no method b ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Type < m : 'a. [< `A of < > ] as 'a > is not a subtype of < m : 'b. [< `A of < p : int > ] as 'b > + Type < > is not a subtype of < p : int > # val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = <fun> # Characters 9-16: fun x -> (f x)#m;; (* Warning 18 *) diff --git a/testsuite/tests/typing-poly/poly.ml.reference b/testsuite/tests/typing-poly/poly.ml.reference index a984afcb3d..f02f252288 100644 --- a/testsuite/tests/typing-poly/poly.ml.reference +++ b/testsuite/tests/typing-poly/poly.ml.reference @@ -437,6 +437,7 @@ Error: This expression has type < m : 'b. 'b * ('b * 'a) > as 'a :> <m : 'a. 'a -> ('a * 'foo)> as 'foo).. Error: Type < m : 'a. 'a -> ('a * (< m : 'c. 'c -> 'b as 'e > as 'd) as 'b) > is not a subtype of < m : 'a. 'a -> ('a * 'f as 'h) as 'g > as 'f + Type 'c. 'e is not a subtype of 'a. 'g # Characters 88-150: = struct let f (x : <m : 'a. 'a * ('a * 'foo)> as 'foo) = () end;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ @@ -490,6 +491,8 @@ Error: Type p = < x : p > is not a subtype of q = < x : p; .. > :> <m:'b. (<p:int;q:int;..> as 'b) -> int>).. Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of < m : 'b. (< p : int; q : int; .. > as 'b) -> int > + Type < p : int; q : int; .. > as 'c is not a subtype of + < p : int; .. > as 'd # val f2 : < m : 'a. (< p : < a : int >; .. > as 'a) -> int > -> < m : 'b. (< p : < a : int; b : int >; .. > as 'b) -> int > = <fun> @@ -498,12 +501,13 @@ Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of :> <m:'b. (<p:<a:int>;..> as 'b) -> int>).. Error: Type < m : 'a. (< p : < a : int; b : int >; .. > as 'a) -> int > is not a subtype of < m : 'b. (< p : < a : int >; .. > as 'b) -> int > + Type < a : int > is not a subtype of < a : int; b : int > # Characters 11-55: let f4 x = (x : <p:<a:int;b:int>;..> :> <p:<a:int>;..>);; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Type < p : < a : int; b : int >; .. > is not a subtype of < p : < a : int >; .. > -The second object type has no method b + The second object type has no method b # val f5 : < m : 'a. [< `A of < p : int > ] as 'a > -> < m : 'b. [< `A of < > ] as 'b > = <fun> @@ -512,6 +516,7 @@ The second object type has no method b ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Type < m : 'a. [< `A of < > ] as 'a > is not a subtype of < m : 'b. [< `A of < p : int > ] as 'b > + Type < > is not a subtype of < p : int > # val f : < m : 'a. 'a -> 'a > -> < m : 'a. 'a -> 'a > = <fun> # - : < m : 'a. 'a -> 'a > -> 'b -> 'b = <fun> # val f : < m : 'a. 'a -> 'a > * 'b -> < m : 'a. 'a -> 'a > = <fun> diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml index ec0052c3be..3eaff045d9 100644 --- a/tools/ocamlcp.ml +++ b/tools/ocamlcp.ml @@ -73,6 +73,7 @@ module Options = Main_args.Make_bytecomp_options (struct let _pp s = incompatible "-pp" let _ppx s = incompatible "-ppx" let _principal = option "-principal" + let _short_paths = option "-short-paths" let _rectypes = option "-rectypes" let _runtime_variant s = option_with_arg "-runtime-variant" s let _strict_sequence = option "-strict-sequence" diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml index 3f6f77cb6a..74d1314aca 100644 --- a/tools/ocamloptp.ml +++ b/tools/ocamloptp.ml @@ -76,6 +76,7 @@ module Options = Main_args.Make_optcomp_options (struct let _pp s = incompatible "-pp" let _ppx s = incompatible "-ppx" let _principal = option "-principal" + let _short_paths = option "-short-paths" let _rectypes = option "-rectypes" let _runtime_variant s = option_with_arg "-runtime-variant" s let _S = option "-S" diff --git a/toplevel/opttopmain.ml b/toplevel/opttopmain.ml index 00d3eb07a5..0217709bc8 100644 --- a/toplevel/opttopmain.ml +++ b/toplevel/opttopmain.ml @@ -76,6 +76,7 @@ module Options = Main_args.Make_opttop_options (struct let _nostdlib = set no_std_include let _ppx s = ppx := s :: !ppx let _principal = set principal + let _real_paths = set real_paths let _rectypes = set recursive_types let _strict_sequence = set strict_sequence let _S = set keep_asm_file diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index 9026dfd504..f1ded5e05d 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -246,13 +246,14 @@ let execute_phrase print_outcome ppf phr = match res with | Result v -> if print_outcome then - match str.str_items with - | [ { str_desc = Tstr_eval exp }] -> - let outv = outval_of_value newenv v exp.exp_type in - let ty = Printtyp.tree_of_type_scheme exp.exp_type in - Ophr_eval (outv, ty) - | [] -> Ophr_signature [] - | _ -> Ophr_signature (item_list newenv sg') + Printtyp.wrap_printing_env oldenv (fun () -> + match str.str_items with + | [ { str_desc = Tstr_eval exp }] -> + let outv = outval_of_value newenv v exp.exp_type in + let ty = Printtyp.tree_of_type_scheme exp.exp_type in + Ophr_eval (outv, ty) + | [] -> Ophr_signature [] + | _ -> Ophr_signature (item_list newenv sg')) else Ophr_signature [] | Exception exn -> toplevel_env := oldenv; diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml index da8ab37649..4ce1ad87be 100644 --- a/toplevel/topmain.ml +++ b/toplevel/topmain.ml @@ -73,6 +73,7 @@ module Options = Main_args.Make_bytetop_options (struct let _nostdlib = set no_std_include let _ppx s = ppx := s :: !ppx let _principal = set principal + let _short_paths = clear real_paths let _rectypes = set recursive_types let _stdin () = file_argument "" let _strict_sequence = set strict_sequence diff --git a/typing/btype.ml b/typing/btype.ml index 08a4a45658..4f24372fb0 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -184,6 +184,12 @@ let is_row_name s = let l = String.length s in if l < 4 then false else String.sub s (l-4) 4 = "#row" +let is_constr_row t = + match t.desc with + Tconstr (Path.Pident id, _, _) -> is_row_name (Ident.name id) + | Tconstr (Path.Pdot (_, s, _), _, _) -> is_row_name s + | _ -> false + (**********************************) (* Utilities for type traversal *) diff --git a/typing/btype.mli b/typing/btype.mli index ba595ad599..88019ff297 100644 --- a/typing/btype.mli +++ b/typing/btype.mli @@ -76,6 +76,7 @@ val proxy: type_expr -> type_expr (**** Utilities for private abbreviations with fixed rows ****) val has_constr_row: type_expr -> bool val is_row_name: string -> bool +val is_constr_row: type_expr -> bool (**** Utilities for type traversal ****) diff --git a/typing/ctype.ml b/typing/ctype.ml index 31059a7f30..7c393f274d 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -3106,11 +3106,11 @@ let eqtype rename type_pairs subst env t1 t2 = type class_match_failure = CM_Virtual_class | CM_Parameter_arity_mismatch of int * int - | CM_Type_parameter_mismatch of (type_expr * type_expr) list - | CM_Class_type_mismatch of class_type * class_type - | CM_Parameter_mismatch of (type_expr * type_expr) list - | CM_Val_type_mismatch of string * (type_expr * type_expr) list - | CM_Meth_type_mismatch of string * (type_expr * type_expr) list + | CM_Type_parameter_mismatch of Env.t * (type_expr * type_expr) list + | CM_Class_type_mismatch of Env.t * class_type * class_type + | CM_Parameter_mismatch of Env.t * (type_expr * type_expr) list + | CM_Val_type_mismatch of string * Env.t * (type_expr * type_expr) list + | CM_Meth_type_mismatch of string * Env.t * (type_expr * type_expr) list | CM_Non_mutable_value of string | CM_Non_concrete_value of string | CM_Missing_value of string @@ -3132,7 +3132,7 @@ let rec moregen_clty trace type_pairs env cty1 cty2 = moregen_clty true type_pairs env cty1 cty2 | Cty_fun (l1, ty1, cty1'), Cty_fun (l2, ty2, cty2') when l1 = l2 -> begin try moregen true type_pairs env ty1 ty2 with Unify trace -> - raise (Failure [CM_Parameter_mismatch (expand_trace env trace)]) + raise (Failure [CM_Parameter_mismatch (env, expand_trace env trace)]) end; moregen_clty false type_pairs env cty1' cty2' | Cty_signature sign1, Cty_signature sign2 -> @@ -3145,7 +3145,7 @@ let rec moregen_clty trace type_pairs env cty1 cty2 = (fun (lab, k1, t1, k2, t2) -> begin try moregen true type_pairs env t1 t2 with Unify trace -> raise (Failure [CM_Meth_type_mismatch - (lab, expand_trace env trace)]) + (lab, env, expand_trace env trace)]) end) pairs; Vars.iter @@ -3153,13 +3153,13 @@ let rec moregen_clty trace type_pairs env cty1 cty2 = let (mut', v', ty') = Vars.find lab sign1.cty_vars in try moregen true type_pairs env ty' ty with Unify trace -> raise (Failure [CM_Val_type_mismatch - (lab, expand_trace env trace)])) + (lab, env, expand_trace env trace)])) sign2.cty_vars | _ -> raise (Failure []) with Failure error when trace || error = [] -> - raise (Failure (CM_Class_type_mismatch (cty1, cty2)::error)) + raise (Failure (CM_Class_type_mismatch (env, cty1, cty2)::error)) let match_class_types ?(trace=true) env pat_sch subj_sch = let type_pairs = TypePairs.create 53 in @@ -3251,7 +3251,7 @@ let match_class_types ?(trace=true) env pat_sch subj_sch = Failure r -> r end | error -> - CM_Class_type_mismatch (patt, subj)::error + CM_Class_type_mismatch (env, patt, subj)::error in current_level := old_level; res @@ -3267,7 +3267,7 @@ let rec equal_clty trace type_pairs subst env cty1 cty2 = equal_clty true type_pairs subst env cty1 cty2 | Cty_fun (l1, ty1, cty1'), Cty_fun (l2, ty2, cty2') when l1 = l2 -> begin try eqtype true type_pairs subst env ty1 ty2 with Unify trace -> - raise (Failure [CM_Parameter_mismatch (expand_trace env trace)]) + raise (Failure [CM_Parameter_mismatch (env, expand_trace env trace)]) end; equal_clty false type_pairs subst env cty1' cty2' | Cty_signature sign1, Cty_signature sign2 -> @@ -3281,7 +3281,7 @@ let rec equal_clty trace type_pairs subst env cty1 cty2 = begin try eqtype true type_pairs subst env t1 t2 with Unify trace -> raise (Failure [CM_Meth_type_mismatch - (lab, expand_trace env trace)]) + (lab, env, expand_trace env trace)]) end) pairs; Vars.iter @@ -3289,15 +3289,15 @@ let rec equal_clty trace type_pairs subst env cty1 cty2 = let (_, _, ty') = Vars.find lab sign1.cty_vars in try eqtype true type_pairs subst env ty' ty with Unify trace -> raise (Failure [CM_Val_type_mismatch - (lab, expand_trace env trace)])) + (lab, env, expand_trace env trace)])) sign2.cty_vars | _ -> raise (Failure (if trace then [] - else [CM_Class_type_mismatch (cty1, cty2)])) + else [CM_Class_type_mismatch (env, cty1, cty2)])) with Failure error when trace -> - raise (Failure (CM_Class_type_mismatch (cty1, cty2)::error)) + raise (Failure (CM_Class_type_mismatch (env, cty1, cty2)::error)) let match_class_declarations env patt_params patt_type subj_params subj_type = let type_pairs = TypePairs.create 53 in @@ -3383,7 +3383,7 @@ let match_class_declarations env patt_params patt_type subj_params subj_type = List.iter2 (fun p s -> try eqtype true type_pairs subst env p s with Unify trace -> raise (Failure [CM_Type_parameter_mismatch - (expand_trace env trace)])) + (env, expand_trace env trace)])) patt_params subj_params; (* old code: equal_clty false type_pairs subst env patt_type subj_type; *) equal_clty false type_pairs subst env diff --git a/typing/ctype.mli b/typing/ctype.mli index e52fec49f4..527be9a37e 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -186,11 +186,11 @@ val matches: Env.t -> type_expr -> type_expr -> bool type class_match_failure = CM_Virtual_class | CM_Parameter_arity_mismatch of int * int - | CM_Type_parameter_mismatch of (type_expr * type_expr) list - | CM_Class_type_mismatch of class_type * class_type - | CM_Parameter_mismatch of (type_expr * type_expr) list - | CM_Val_type_mismatch of string * (type_expr * type_expr) list - | CM_Meth_type_mismatch of string * (type_expr * type_expr) list + | CM_Type_parameter_mismatch of Env.t * (type_expr * type_expr) list + | CM_Class_type_mismatch of Env.t * class_type * class_type + | CM_Parameter_mismatch of Env.t * (type_expr * type_expr) list + | CM_Val_type_mismatch of string * Env.t * (type_expr * type_expr) list + | CM_Meth_type_mismatch of string * Env.t * (type_expr * type_expr) list | CM_Non_mutable_value of string | CM_Non_concrete_value of string | CM_Missing_value of string diff --git a/typing/env.ml b/typing/env.ml index 0581517ced..2018753f95 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -65,6 +65,7 @@ module EnvLazy : sig val force : ('a -> 'b) -> ('a,'b) t -> 'b val create : 'a -> ('a,'b) t + val is_val : ('a,'b) t -> bool end = struct @@ -88,6 +89,9 @@ end = struct x := Raise e; raise e + let is_val x = + match !x with Done _ -> true | _ -> false + let create x = let x = ref (Thunk x) in x @@ -765,6 +769,37 @@ let lookup_cltype lid env = mark_type_path env desc.clty_path; r +(* Iter on an environment (ignoring the body of functors and + not yet evaluated structures) *) + +let iter_env proj1 proj2 f env = + Ident.iter (fun id (x,_) -> f (Pident id) x) (proj1 env); + let rec iter_components path path' mcomps = + if EnvLazy.is_val mcomps then + match EnvLazy.force !components_of_module_maker' mcomps with + Structure_comps comps -> + Tbl.iter + (fun s (d, n) -> f (Pdot (path, s, n)) (Pdot (path', s, n), d)) + (proj2 comps); + Tbl.iter + (fun s (c, n) -> + iter_components (Pdot (path, s, n)) (Pdot (path', s, n)) c) + comps.comp_components + | Functor_comps _ -> () + in + Hashtbl.iter + (fun s pso -> + match pso with None -> () + | Some ps -> + let id = Pident (Ident.create_persistent s) in + iter_components id id ps.ps_comps) + persistent_structures; + Ident.iter + (fun id ((path, comps), _) -> iter_components (Pident id) path comps) + env.components + +let iter_types f = iter_env (fun env -> env.types) (fun sc -> sc.comp_types) f + (* GADT instance tracking *) let add_gadt_instance_level lv env = diff --git a/typing/env.mli b/typing/env.mli index 67caf57d97..5da976399f 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -34,6 +34,10 @@ val diff: t -> t -> Ident.t list type type_descriptions = constructor_description list * label_description list +val iter_types: + (Path.t -> Path.t * (type_declaration * type_descriptions) -> unit) -> + t -> unit + (* Lookup by paths *) val find_value: Path.t -> t -> value_description diff --git a/typing/ident.ml b/typing/ident.ml index c448f42505..70438c83d0 100644 --- a/typing/ident.ml +++ b/typing/ident.ml @@ -204,3 +204,8 @@ let fold_all f tbl accu = fold_aux (fun k -> fold_data f (Some k)) [] accu tbl (* let keys tbl = fold_name (fun k _ accu -> k::accu) tbl [] *) + +let rec iter f = function + Empty -> () + | Node(l, k, r, _) -> + iter f l; f k.ident k.data; iter f r diff --git a/typing/ident.mli b/typing/ident.mli index 05a675d66e..e27d4d4a64 100644 --- a/typing/ident.mli +++ b/typing/ident.mli @@ -57,3 +57,5 @@ val find_name: string -> 'a tbl -> 'a val find_all: string -> 'a tbl -> 'a list val fold_name: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b val fold_all: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b +val iter: (t -> 'a -> unit) -> 'a tbl -> unit + diff --git a/typing/includeclass.ml b/typing/includeclass.ml index 05a49bf437..2f5aac18b4 100644 --- a/typing/includeclass.ml +++ b/typing/includeclass.ml @@ -47,36 +47,35 @@ let include_err ppf = | CM_Parameter_arity_mismatch (ls, lp) -> fprintf ppf "The classes do not have the same number of type parameters" - | CM_Type_parameter_mismatch trace -> - fprintf ppf "@[%a@]" - (Printtyp.unification_error false trace + | CM_Type_parameter_mismatch (env, trace) -> + Printtyp.report_unification_error ppf env ~unif:false trace (function ppf -> - fprintf ppf "A type parameter has type")) + fprintf ppf "A type parameter has type") (function ppf -> fprintf ppf "but is expected to have type") - | CM_Class_type_mismatch (cty1, cty2) -> - fprintf ppf - "@[The class type@;<1 2>%a@ is not matched by the class type@;<1 2>%a@]" - Printtyp.class_type cty1 Printtyp.class_type cty2 - | CM_Parameter_mismatch trace -> - fprintf ppf "@[%a@]" - (Printtyp.unification_error false trace + | CM_Class_type_mismatch (env, cty1, cty2) -> + Printtyp.wrap_printing_env env (fun () -> + fprintf ppf + "@[The class type@;<1 2>%a@ %s@;<1 2>%a@]" + Printtyp.class_type cty1 + "is not matched by the class type" + Printtyp.class_type cty2) + | CM_Parameter_mismatch (env, trace) -> + Printtyp.report_unification_error ppf env ~unif:false trace (function ppf -> - fprintf ppf "A parameter has type")) + fprintf ppf "A parameter has type") (function ppf -> fprintf ppf "but is expected to have type") - | CM_Val_type_mismatch (lab, trace) -> - fprintf ppf "@[%a@]" - (Printtyp.unification_error false trace + | CM_Val_type_mismatch (lab, env, trace) -> + Printtyp.report_unification_error ppf env ~unif:false trace (function ppf -> - fprintf ppf "The instance variable %s@ has type" lab)) + fprintf ppf "The instance variable %s@ has type" lab) (function ppf -> fprintf ppf "but is expected to have type") - | CM_Meth_type_mismatch (lab, trace) -> - fprintf ppf "@[%a@]" - (Printtyp.unification_error false trace + | CM_Meth_type_mismatch (lab, env, trace) -> + Printtyp.report_unification_error ppf env ~unif:false trace (function ppf -> - fprintf ppf "The method %s@ has type" lab)) + fprintf ppf "The method %s@ has type" lab) (function ppf -> fprintf ppf "but is expected to have type") | CM_Non_mutable_value lab -> diff --git a/typing/includemod.ml b/typing/includemod.ml index 5a1d4b9420..180ba272c4 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -38,7 +38,7 @@ type symptom = type pos = Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t -type error = pos list * symptom +type error = pos list * Env.t * symptom exception Error of error list @@ -54,7 +54,7 @@ let value_descriptions env cxt subst id vd1 vd2 = try Includecore.value_descriptions env vd1 vd2 with Includecore.Dont_match -> - raise(Error[cxt, Value_descriptions(id, vd1, vd2)]) + raise(Error[cxt, env, Value_descriptions(id, vd1, vd2)]) (* Inclusion between type declarations *) @@ -62,7 +62,8 @@ let type_declarations env cxt subst id decl1 decl2 = Env.mark_type_used (Ident.name id) decl1; let decl2 = Subst.type_declaration subst decl2 in let err = Includecore.type_declarations env (Ident.name id) decl1 id decl2 in - if err <> [] then raise(Error[cxt, Type_declarations(id, decl1, decl2, err)]) + if err <> [] then + raise(Error[cxt, env, Type_declarations(id, decl1, decl2, err)]) (* Inclusion between exception declarations *) @@ -71,7 +72,7 @@ let exception_declarations env cxt subst id decl1 decl2 = let decl2 = Subst.exception_declaration subst decl2 in if Includecore.exception_declarations env decl1 decl2 then () - else raise(Error[cxt, Exception_declarations(id, decl1, decl2)]) + else raise(Error[cxt, env, Exception_declarations(id, decl1, decl2)]) (* Inclusion between class declarations *) @@ -80,13 +81,14 @@ let class_type_declarations env cxt subst id decl1 decl2 = match Includeclass.class_type_declarations env decl1 decl2 with [] -> () | reason -> - raise(Error[cxt, Class_type_declarations(id, decl1, decl2, reason)]) + raise(Error[cxt, env, Class_type_declarations(id, decl1, decl2, reason)]) let class_declarations env cxt subst id decl1 decl2 = let decl2 = Subst.class_declaration subst decl2 in match Includeclass.class_declarations env decl1 decl2 with [] -> () - | reason -> raise(Error[cxt, Class_declarations(id, decl1, decl2, reason)]) + | reason -> + raise(Error[cxt, env, Class_declarations(id, decl1, decl2, reason)]) (* Expand a module type identifier when possible *) @@ -96,7 +98,7 @@ let expand_module_path env cxt path = try Env.find_modtype_expansion path env with Not_found -> - raise(Error[cxt, Unbound_modtype_path path]) + raise(Error[cxt, env, Unbound_modtype_path path]) (* Extract name, kind and ident from a signature item *) @@ -139,9 +141,9 @@ let rec modtypes env cxt subst mty1 mty2 = try_modtypes env cxt subst mty1 mty2 with Dont_match -> - raise(Error[cxt, Module_types(mty1, Subst.modtype subst mty2)]) + raise(Error[cxt, env, Module_types(mty1, Subst.modtype subst mty2)]) | Error reasons -> - raise(Error((cxt, Module_types(mty1, Subst.modtype subst mty2)) + raise(Error((cxt, env, Module_types(mty1, Subst.modtype subst mty2)) :: reasons)) and try_modtypes env cxt subst mty1 mty2 = @@ -241,7 +243,8 @@ and signatures env cxt subst sig1 sig2 = ((item1, item2, pos1) :: paired) unpaired rem with Not_found -> let unpaired = - if report then (cxt, Missing_field id2) :: unpaired else unpaired in + if report then (cxt, env, Missing_field id2) :: unpaired + else unpaired in pair_components subst paired unpaired rem end in (* Do the pairing and checking, and return the final coercion *) @@ -296,7 +299,7 @@ and modtype_infos env cxt subst id info1 info2 = | (Modtype_abstract, Modtype_manifest mty2) -> check_modtype_equiv env cxt' (Mty_ident(Pident id)) mty2 with Error reasons -> - raise(Error((cxt, Modtype_infos(id, info1, info2)) :: reasons)) + raise(Error((cxt, env, Modtype_infos(id, info1, info2)) :: reasons)) and check_modtype_equiv env cxt mty1 mty2 = match @@ -304,7 +307,7 @@ and check_modtype_equiv env cxt mty1 mty2 = modtypes env cxt Subst.identity mty2 mty1) with (Tcoerce_none, Tcoerce_none) -> () - | (_, _) -> raise(Error [cxt, Modtype_permutation]) + | (_, _) -> raise(Error [cxt, env, Modtype_permutation]) (* Simplified inclusion check between module types (for Env) *) @@ -324,7 +327,8 @@ let compunit impl_name impl_sig intf_name intf_sig = try signatures Env.initial [] Subst.identity impl_sig intf_sig with Error reasons -> - raise(Error(([], Interface_mismatch(impl_name, intf_name)) :: reasons)) + raise(Error(([], Env.empty,Interface_mismatch(impl_name, intf_name)) + :: reasons)) (* Hide the context and substitution parameters to the outside world *) @@ -444,8 +448,9 @@ let context ppf cxt = else fprintf ppf "@[<hv 2>At position@ %a@]@ " context cxt -let include_err ppf (cxt, err) = - fprintf ppf "@[<v>%a%a@]" context (List.rev cxt) include_err err +let include_err ppf (cxt, env, err) = + Printtyp.wrap_printing_env env (fun () -> + fprintf ppf "@[<v>%a%a@]" context (List.rev cxt) include_err err) let buffer = ref "" let is_big obj = @@ -461,8 +466,8 @@ let report_error ppf errs = if errs = [] then () else let (errs , err) = split_last errs in let pe = ref true in - let include_err' ppf err = - if not (is_big err) then fprintf ppf "%a@ " include_err err + let include_err' ppf (_,_,obj as err) = + if not (is_big obj) then fprintf ppf "%a@ " include_err err else if !pe then (fprintf ppf "...@ "; pe := false) in let print_errs ppf = List.iter (include_err' ppf) in diff --git a/typing/includemod.mli b/typing/includemod.mli index 5f2c414ae9..75afef574c 100644 --- a/typing/includemod.mli +++ b/typing/includemod.mli @@ -43,7 +43,7 @@ type symptom = type pos = Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t -type error = pos list * symptom +type error = pos list * Env.t * symptom exception Error of error list diff --git a/typing/printtyp.ml b/typing/printtyp.ml index 69ca127303..fe94d8fb98 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -189,6 +189,109 @@ let raw_type_expr ppf t = let () = Btype.print_raw := raw_type_expr +(* Normalize paths *) + +type param_subst = Id | Nth of int | Map of int list + +let compose l1 = function + | Id -> Map l1 + | Map l2 -> Map (List.map (List.nth l1) l2) + | Nth n -> Nth (List.nth l1 n) + +let apply_subst s1 tyl = + match s1 with + Nth n1 -> [List.nth tyl n1] + | Map l1 -> List.map (List.nth tyl) l1 + | Id -> tyl + +let printing_env = ref Env.empty +let printing_map = ref (Lazy.lazy_from_val Tbl.empty) + +let same_type t t' = repr t == repr t' + +let rec index l x = + match l with + [] -> raise Not_found + | a :: l -> if x == a then 0 else 1 + index l x + +let rec uniq = function + [] -> true + | a :: l -> not (List.memq a l) && uniq l + +let rec normalize_type_path ?(cache=false) env p = + try + let desc = Env.find_type p env in + if desc.type_private = Private || desc.type_newtype_level <> None then + (p, Id) + else match desc.type_manifest with + Some ty -> + let params = List.map repr desc.type_params in + begin match repr ty with + {desc = Tconstr (p1, tyl, _)} -> + let tyl = List.map repr tyl in + if List.length params = List.length tyl + && List.for_all2 (==) params tyl + then normalize_type_path ~cache env p1 + else if cache || List.length params <= List.length tyl + || not (uniq tyl) then (p, Id) + else + let l1 = List.map (index params) tyl in + let (p2, s2) = normalize_type_path ~cache env p1 in + (p2, compose l1 s2) + | ty -> + (p, Nth (index params ty)) + end + | None -> (p, Id) + with + Not_found -> (p, Id) + +let rec path_size = function + Pident id -> + (let s = Ident.name id in if s <> "" && s.[0] = '_' then 10 else 1), + -Ident.binding_time id + | Pdot (p, _, _) -> + let (l, b) = path_size p in (1+l, b) + | Papply (p1, p2) -> + let (l, b) = path_size p1 in + (l + fst (path_size p2), b) + +let set_printing_env env = + if not !Clflags.real_paths && env != !printing_env then begin + (* printf "Reset printing_map@."; *) + printing_env := env; + printing_map := lazy begin + (* printf "Recompute printing_map.@."; *) + let map = ref Tbl.empty in + Env.iter_types + (fun p (p', decl) -> + let (p1, s1) = normalize_type_path env p' ~cache:true in + if s1 = Id then + try + let p2 = Tbl.find p1 !map in + if path_size p < path_size p2 then raise Not_found + with Not_found -> + (* printf "%a --> %a@." path p1 path p; *) + map := Tbl.add p1 p !map) + env; + !map + end + end + +let wrap_printing_env env f = + if env == !printing_env then f () else + begin + set_printing_env env; + try_finally f (fun () -> set_printing_env Env.empty) + end + +let best_type_path p = + if !Clflags.real_paths || !printing_env == Env.empty + then (p, Id) + else + let (p', s) = normalize_type_path !printing_env p in + (try Tbl.find p' (Lazy.force !printing_map) with Not_found -> p'), + s + (* Print a type expression *) let names = ref ([] : (type_expr * string) list) @@ -269,7 +372,11 @@ let add_alias ty = end let aliasable ty = - match ty.desc with Tvar _ | Tunivar _ | Tpoly _ -> false | _ -> true + match ty.desc with + Tvar _ | Tunivar _ | Tpoly _ -> false + | Tconstr (p, _, _) -> + (match best_type_path p with (_, Nth _) -> false | _ -> true) + | _ -> true let namable_row row = row.row_name <> None && @@ -291,7 +398,10 @@ let rec mark_loops_rec visited ty = | Tarrow(_, ty1, ty2, _) -> mark_loops_rec visited ty1; mark_loops_rec visited ty2 | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl - | Tconstr(_, tyl, _) | Tpackage (_, _, tyl) -> + | Tconstr(p, tyl, _) -> + let (p', s) = best_type_path p in + List.iter (mark_loops_rec visited) (apply_subst s tyl) + | Tpackage (_, _, tyl) -> List.iter (mark_loops_rec visited) tyl | Tvariant row -> if List.memq px !visited_objects then add_alias px else @@ -384,7 +494,12 @@ let rec tree_of_typexp sch ty = | Ttuple tyl -> Otyp_tuple (tree_of_typlist sch tyl) | Tconstr(p, tyl, abbrev) -> - Otyp_constr (tree_of_path p, tree_of_typlist sch tyl) + begin match best_type_path p with + (_, Nth n) -> tree_of_typexp sch (List.nth tyl n) + | (p', s) -> + let tyl' = apply_subst s tyl in + Otyp_constr (tree_of_path p', tree_of_typlist sch tyl') + end | Tvariant row -> let row = row_repr row in let fields = @@ -402,7 +517,9 @@ let rec tree_of_typexp sch ty = let all_present = List.length present = List.length fields in begin match row.row_name with | Some(p, tyl) when namable_row row -> - let id = tree_of_path p in + let (p', s) = best_type_path p in + assert (s = Id); + let id = tree_of_path p' in let args = tree_of_typlist sch tyl in if row.row_closed && all_present then Otyp_constr (id, args) @@ -410,7 +527,7 @@ let rec tree_of_typexp sch ty = let non_gen = is_non_gen sch px in let tags = if all_present then None else Some (List.map fst present) in - Otyp_variant (non_gen, Ovar_name(tree_of_path p, args), + Otyp_variant (non_gen, Ovar_name(id, args), row.row_closed, tags) | _ -> let non_gen = @@ -492,7 +609,9 @@ and tree_of_typobject sch fi nm = | Some (p, ty :: tyl) -> let non_gen = is_non_gen sch (repr ty) in let args = tree_of_typlist sch tyl in - Otyp_class (non_gen, tree_of_path p, args) + let (p', s) = best_type_path p in + assert (s = Id); + Otyp_class (non_gen, tree_of_path p', args) | _ -> fatal_error "Printtyp.tree_of_typobject" end @@ -868,6 +987,22 @@ let cltype_declaration id ppf cl = (* Print a module type *) +let wrap_env fenv ftree arg = + let env = !printing_env in + set_printing_env (fenv env); + let tree = ftree arg in + set_printing_env env; + tree + +let filter_rem_sig item rem = + match item, rem with + | Sig_class _, ctydecl :: tydecl1 :: tydecl2 :: rem -> + ([ctydecl; tydecl1; tydecl2], rem) + | Sig_class_type _, tydecl1 :: tydecl2 :: rem -> + ([tydecl1; tydecl2], rem) + | _ -> + ([], rem) + let rec tree_of_modtype = function | Mty_ident p -> Omty_ident (tree_of_path p) @@ -875,30 +1010,37 @@ let rec tree_of_modtype = function Omty_signature (tree_of_signature sg) | Mty_functor(param, ty_arg, ty_res) -> Omty_functor - (Ident.name param, tree_of_modtype ty_arg, tree_of_modtype ty_res) - -and tree_of_signature = function - | [] -> [] - | Sig_value(id, decl) :: rem -> - tree_of_value_description id decl :: tree_of_signature rem - | Sig_type(id, _, _) :: rem when is_row_name (Ident.name id) -> - tree_of_signature rem - | Sig_type(id, decl, rs) :: rem -> - Osig_type(tree_of_type_decl id decl, tree_of_rec rs) :: - tree_of_signature rem - | Sig_exception(id, decl) :: rem -> - tree_of_exception_declaration id decl :: tree_of_signature rem - | Sig_module(id, mty, rs) :: rem -> - Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs) :: - tree_of_signature rem - | Sig_modtype(id, decl) :: rem -> - tree_of_modtype_declaration id decl :: tree_of_signature rem - | Sig_class(id, decl, rs) :: ctydecl :: tydecl1 :: tydecl2 :: rem -> - tree_of_class_declaration id decl rs :: tree_of_signature rem - | Sig_class_type(id, decl, rs) :: tydecl1 :: tydecl2 :: rem -> - tree_of_cltype_declaration id decl rs :: tree_of_signature rem - | _ -> - assert false + (Ident.name param, tree_of_modtype ty_arg, + wrap_env (Env.add_module param ty_arg) tree_of_modtype ty_res) + +and tree_of_signature sg = + wrap_env (fun env -> env) tree_of_signature_rec sg + +and tree_of_signature_rec = function + [] -> [] + | item :: rem -> + let (sg, rem) = filter_rem_sig item rem in + let trees = + match item with + | Sig_value(id, decl) -> + [tree_of_value_description id decl] + | Sig_type(id, _, _) when is_row_name (Ident.name id) -> + [] + | Sig_type(id, decl, rs) -> + [Osig_type(tree_of_type_decl id decl, tree_of_rec rs)] + | Sig_exception(id, decl) -> + [tree_of_exception_declaration id decl] + | Sig_module(id, mty, rs) -> + [Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs)] + | Sig_modtype(id, decl) -> + [tree_of_modtype_declaration id decl] + | Sig_class(id, decl, rs) -> + [tree_of_class_declaration id decl rs] + | Sig_class_type(id, decl, rs) -> + [tree_of_cltype_declaration id decl rs] + in + set_printing_env (Env.add_signature (item :: sg) !printing_env); + trees @ tree_of_signature_rec rem and tree_of_modtype_declaration id decl = let mty = @@ -925,8 +1067,25 @@ let signature ppf sg = (* Print an unification error *) +let same_path t t' = + let t = repr t and t' = repr t' in + t == t' || + match t.desc, t'.desc with + Tconstr(p,tl,_), Tconstr(p',tl',_) -> + let (p1, s1) = best_type_path p and (p2, s2) = best_type_path p' in + begin match s1, s2 with + Nth n1, Nth n2 when n1 = n2 -> true + | (Id | Map _), (Id | Map _) when Path.same p1 p2 -> + let tl = apply_subst s1 tl and tl' = apply_subst s2 tl' in + List.length tl = List.length tl' && + List.for_all2 same_type tl tl' + | _ -> false + end + | _ -> + false + let type_expansion t ppf t' = - if t == t' then type_expr ppf t else + if same_path t t' then type_expr ppf t else let t' = if proxy t == proxy t' then unalias t' else t' in fprintf ppf "@[<2>%a@ =@ %a@]" type_expr t type_expr t' @@ -942,12 +1101,13 @@ let rec trace fst txt ppf = function (trace false txt) rem | _ -> () -let rec filter_trace = function +let rec filter_trace keep_last = function | (_, t1') :: (_, t2') :: [] when is_Tvar t1' || is_Tvar t2' -> [] | (t1, t1') :: (t2, t2') :: rem -> - let rem' = filter_trace rem in - if t1 == t1' && t2 == t2' + let rem' = filter_trace keep_last rem in + if is_constr_row t1' || is_constr_row t2' + || same_path t1 t1' && same_path t2 t2' && not (keep_last && rem' = []) then rem' else (t1, t1') :: (t2, t2') :: rem' | _ -> [] @@ -971,7 +1131,8 @@ let hide_variant_name t = let prepare_expansion (t, t') = let t' = hide_variant_name t' in - mark_loops t; if t != t' then mark_loops t'; + mark_loops t; + if not (same_path t t') then mark_loops t'; (t, t') let may_prepare_expansion compact (t, t') = @@ -989,6 +1150,7 @@ let print_tags ppf fields = let has_explanation unif t3 t4 = match t3.desc, t4.desc with Tfield _, (Tnil|Tconstr _) | (Tnil|Tconstr _), Tfield _ + | Tnil, Tconstr _ | Tconstr _, Tnil | _, Tvar _ | Tvar _, _ | Tvariant _, Tvariant _ -> true | Tfield (l,_,_,{desc=Tnil}), Tfield (l',_,_,{desc=Tnil}) -> l = l' @@ -1042,6 +1204,10 @@ let explanation unif t3 t4 ppf = | Tfield (l, _, _, _), (Tnil|Tconstr _) -> fprintf ppf "@,@[The second object type has no method %s@]" l + | Tnil, Tconstr _ | Tconstr _, Tnil -> + fprintf ppf + "@,@[The %s object type has an abstract row, it cannot be closed@]" + (if t4.desc = Tnil then "first" else "second") | Tvariant row1, Tvariant row2 -> let row1 = row_repr row1 and row2 = row_repr row2 in begin match @@ -1082,7 +1248,8 @@ let rec path_same_name p1 p2 = let type_same_name t1 t2 = match (repr t1).desc, (repr t2).desc with - Tconstr (p1, _, _), Tconstr (p2, _, _) -> path_same_name p1 p2 + Tconstr (p1, _, _), Tconstr (p2, _, _) -> + path_same_name (fst (best_type_path p1)) (fst (best_type_path p2)) | _ -> () let rec trace_same_names = function @@ -1099,7 +1266,7 @@ let unification_error unif tr txt1 ppf txt2 = | [] | _ :: [] -> assert false | t1 :: t2 :: tr -> try - let tr = filter_trace tr in + let tr = filter_trace (mis = None) tr in let t1, t1' = may_prepare_expansion (tr = []) t1 and t2, t2' = may_prepare_expansion (tr = []) t2 in print_labels := not !Clflags.classic; @@ -1119,50 +1286,55 @@ let unification_error unif tr txt1 ppf txt2 = print_labels := true; raise exn -let report_unification_error ppf tr txt1 txt2 = - unification_error true tr txt1 ppf txt2;; +let report_unification_error ppf env ?(unif=true) + tr txt1 txt2 = + wrap_printing_env env (fun () -> unification_error unif tr txt1 ppf txt2) +;; -let trace fst txt ppf tr = +let trace fst keep_last txt ppf tr = print_labels := not !Clflags.classic; trace_same_names tr; try match tr with t1 :: t2 :: tr' -> - if fst then trace fst txt ppf (t1 :: t2 :: filter_trace tr') - else trace fst txt ppf (filter_trace tr); + if fst then trace fst txt ppf (t1 :: t2 :: filter_trace keep_last tr') + else trace fst txt ppf (filter_trace keep_last tr); print_labels := true | _ -> () with exn -> print_labels := true; raise exn -let report_subtyping_error ppf tr1 txt1 tr2 = - reset (); - let tr1 = List.map prepare_expansion tr1 - and tr2 = List.map prepare_expansion tr2 in - trace true txt1 ppf tr1; - if tr2 = [] then () else - let mis = mismatch true tr2 in - trace false "is not compatible with type" ppf tr2; - explanation true mis ppf - -let report_ambiguous_type_error ppf (tp0, tp0') tpl txt1 txt2 txt3 = - reset (); - List.iter - (fun (tp, tp') -> path_same_name tp0 tp; path_same_name tp0' tp') - tpl; - match tpl with - [] -> assert false - | [tp, tp'] -> - fprintf ppf - "@[%t@;<1 2>%a@ \ - %t@;<1 2>%a\ - @]" - txt1 (type_path_expansion tp) tp' - txt3 (type_path_expansion tp0) tp0' - | _ -> - fprintf ppf - "@[%t@;<1 2>@[<hv>%a@]\ - @ %t@;<1 2>%a\ - @]" - txt2 type_path_list tpl - txt3 (type_path_expansion tp0) tp0' +let report_subtyping_error ppf env tr1 txt1 tr2 = + wrap_printing_env env (fun () -> + reset (); + let tr1 = List.map prepare_expansion tr1 + and tr2 = List.map prepare_expansion tr2 in + fprintf ppf "@[<v>%a" (trace true (tr2 = []) txt1) tr1; + if tr2 = [] then fprintf ppf "@]" else + let mis = mismatch true tr2 in + fprintf ppf "%a%t@]" + (trace false (mis = None) "is not compatible with type") tr2 + (explanation true mis)) + +let report_ambiguous_type_error ppf env (tp0, tp0') tpl txt1 txt2 txt3 = + wrap_printing_env env (fun () -> + reset (); + List.iter + (fun (tp, tp') -> path_same_name tp0 tp; path_same_name tp0' tp') + tpl; + match tpl with + [] -> assert false + | [tp, tp'] -> + fprintf ppf + "@[%t@;<1 2>%a@ \ + %t@;<1 2>%a\ + @]" + txt1 (type_path_expansion tp) tp' + txt3 (type_path_expansion tp0) tp0' + | _ -> + fprintf ppf + "@[%t@;<1 2>@[<hv>%a@]\ + @ %t@;<1 2>%a\ + @]" + txt2 type_path_list tpl + txt3 (type_path_expansion tp0) tp0') diff --git a/typing/printtyp.mli b/typing/printtyp.mli index 7aff325747..09edd43527 100644 --- a/typing/printtyp.mli +++ b/typing/printtyp.mli @@ -21,6 +21,11 @@ val ident: formatter -> Ident.t -> unit val tree_of_path: Path.t -> out_ident val path: formatter -> Path.t -> unit val raw_type_expr: formatter -> type_expr -> unit + +val wrap_printing_env: Env.t -> (unit -> 'a) -> 'a + (* Call the function using the environment for type path shortening *) + (* This affects all the printing functions below *) + val reset: unit -> unit val mark_loops: type_expr -> unit val reset_and_mark_loops: type_expr -> unit @@ -60,19 +65,16 @@ val tree_of_cltype_declaration: val cltype_declaration: Ident.t -> formatter -> class_type_declaration -> unit val type_expansion: type_expr -> Format.formatter -> type_expr -> unit val prepare_expansion: type_expr * type_expr -> type_expr * type_expr -val trace: bool -> string -> formatter -> (type_expr * type_expr) list -> unit -val unification_error: - bool -> (type_expr * type_expr) list -> - (formatter -> unit) -> formatter -> (formatter -> unit) -> - unit +val trace: + bool -> bool-> string -> formatter -> (type_expr * type_expr) list -> unit val report_unification_error: - formatter -> (type_expr * type_expr) list -> + formatter -> Env.t -> ?unif:bool -> (type_expr * type_expr) list -> (formatter -> unit) -> (formatter -> unit) -> unit val report_subtyping_error: - formatter -> (type_expr * type_expr) list -> + formatter -> Env.t -> (type_expr * type_expr) list -> string -> (type_expr * type_expr) list -> unit val report_ambiguous_type_error: - formatter -> (Path.t * Path.t) -> (Path.t * Path.t) list -> + formatter -> Env.t -> (Path.t * Path.t) -> (Path.t * Path.t) list -> (formatter -> unit) -> (formatter -> unit) -> (formatter -> unit) -> unit diff --git a/typing/stypes.ml b/typing/stypes.ml index 55e882c3b6..042821619d 100644 --- a/typing/stypes.ml +++ b/typing/stypes.ml @@ -146,8 +146,8 @@ let print_ident_annot pp str k = let print_info pp ppf prev_loc ti = match ti with | Ti_class _ | Ti_mod _ -> prev_loc - | Ti_pat {pat_loc = loc; pat_type = typ} - | Ti_expr {exp_loc = loc; exp_type = typ} -> + | Ti_pat {pat_loc = loc; pat_type = typ; pat_env = env} + | Ti_expr {exp_loc = loc; exp_type = typ; exp_env = env} -> if loc <> prev_loc then begin print_location pp loc; output_char pp '\n' @@ -157,7 +157,7 @@ let print_info pp ppf prev_loc ti = printtyp_reset_maybe loc; Printtyp.mark_loops typ; Format.pp_print_string ppf " "; - Printtyp.type_sch ppf typ; + Printtyp.wrap_printing_env env (fun () -> Printtyp.type_sch ppf typ); Format.pp_print_newline ppf (); output_string pp ")\n"; loc diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 2becf5d016..fee65fad66 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -46,6 +46,8 @@ type error = | Mutability_mismatch of string * mutable_flag | No_overriding of string * string +exception Error of Location.t * Env.t * error + open Typedtree let ctyp desc typ env loc = @@ -56,8 +58,6 @@ let mkcf desc loc = { cf_desc = desc; cf_loc = loc } let mkctf desc loc = { ctf_desc = desc; ctf_loc = loc } -exception Error of Location.t * error - (**********************) (* Useful constants *) @@ -216,13 +216,15 @@ let enter_val cl_num vars inh lab mut virt ty val_env met_env par_env loc = let (id, virt) = try let (id, mut', virt', ty') = Vars.find lab !vars in - if mut' <> mut then raise (Error(loc, Mutability_mismatch(lab, mut))); + if mut' <> mut then + raise (Error(loc, val_env, Mutability_mismatch(lab, mut))); Ctype.unify val_env (instance ty) (instance ty'); (if not inh then Some id else None), (if virt' = Concrete then virt' else virt) with Ctype.Unify tr -> - raise (Error(loc, Field_type_mismatch("instance variable", lab, tr))) + raise (Error(loc, val_env, + Field_type_mismatch("instance variable", lab, tr))) | Not_found -> None, virt in let (id, _, _, _) as result = @@ -249,7 +251,7 @@ let inheritance self_type env ovf concr_meths warn_vals loc parent = with Ctype.Unify trace -> match trace with _::_::_::({desc = Tfield(n, _, _, _)}, _)::rem -> - raise(Error(loc, Field_type_mismatch ("method", n, rem))) + raise(Error(loc, env, Field_type_mismatch ("method", n, rem))) | _ -> assert false end; @@ -274,7 +276,7 @@ let inheritance self_type env ovf concr_meths warn_vals loc parent = (cname :: Concr.elements over_vals)); | Some Override when Concr.is_empty over_meths && Concr.is_empty over_vals -> - raise (Error(loc, No_overriding ("",""))) + raise (Error(loc, env, No_overriding ("",""))) | _ -> () end; @@ -284,7 +286,7 @@ let inheritance self_type env ovf concr_meths warn_vals loc parent = (cl_sig, concr_meths, warn_vals) | _ -> - raise(Error(loc, Structure_expected parent)) + raise(Error(loc, env, Structure_expected parent)) let virtual_method val_env meths self_type lab priv sty loc = let (_, ty') = @@ -294,7 +296,7 @@ let virtual_method val_env meths self_type lab priv sty loc = let ty = cty.ctyp_type in begin try Ctype.unify val_env ty ty' with Ctype.Unify trace -> - raise(Error(loc, Field_type_mismatch ("method", lab, trace))); + raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace))); end; cty @@ -306,7 +308,7 @@ let declare_method val_env meths self_type lab priv sty loc = in let unif ty = try Ctype.unify val_env ty ty' with Ctype.Unify trace -> - raise(Error(loc, Field_type_mismatch ("method", lab, trace))) + raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace))) in match sty.ptyp_desc, priv with Ptyp_poly ([],sty'), Public -> @@ -336,7 +338,7 @@ let type_constraint val_env sty sty' loc = let ty' = cty'.ctyp_type in begin try Ctype.unify val_env ty ty' with Ctype.Unify trace -> - raise(Error(loc, Unconsistent_constraint trace)); + raise(Error(loc, val_env, Unconsistent_constraint trace)); end; (cty, cty') @@ -420,7 +422,7 @@ and class_signature env sty sign loc = begin try Ctype.unify env self_type dummy_obj with Ctype.Unify _ -> - raise(Error(sty.ptyp_loc, Pattern_type_clash self_type)) + raise(Error(sty.ptyp_loc, env, Pattern_type_clash self_type)) end; (* Class type fields *) @@ -446,12 +448,12 @@ and class_type env scty = Pcty_constr (lid, styl) -> let (path, decl) = Typetexp.find_class_type env scty.pcty_loc lid.txt in if Path.same decl.clty_path unbound_class then - raise(Error(scty.pcty_loc, Unbound_class_type_2 lid.txt)); + raise(Error(scty.pcty_loc, env, Unbound_class_type_2 lid.txt)); let (params, clty) = Ctype.instance_class decl.clty_params decl.clty_type in if List.length params <> List.length styl then - raise(Error(scty.pcty_loc, + raise(Error(scty.pcty_loc, env, Parameter_arity_mismatch (lid.txt, List.length params, List.length styl))); let ctys = List.map2 @@ -460,7 +462,7 @@ and class_type env scty = let ty' = cty'.ctyp_type in begin try Ctype.unify env ty' ty with Ctype.Unify trace -> - raise(Error(sty.ptyp_loc, Parameter_mismatch trace)) + raise(Error(sty.ptyp_loc, env, Parameter_mismatch trace)) end; cty' ) styl params @@ -566,12 +568,13 @@ let rec class_field self_loc cl_num self_type meths vars (Warnings.Instance_variable_override[lab.txt]) end else begin if ovf = Override then - raise(Error(loc, No_overriding ("instance variable", lab.txt))) + raise(Error(loc, val_env, + No_overriding ("instance variable", lab.txt))) end; if !Clflags.principal then Ctype.begin_def (); let exp = try type_exp val_env sexp with Ctype.Unify [(ty, _)] -> - raise(Error(loc, Make_nongen_seltype ty)) + raise(Error(loc, val_env, Make_nongen_seltype ty)) in if !Clflags.principal then begin Ctype.end_def (); @@ -600,7 +603,7 @@ let rec class_field self_loc cl_num self_type meths vars Location.prerr_warning loc (Warnings.Method_override [lab.txt]) end else begin if ovf = Override then - raise(Error(loc, No_overriding("method", lab.txt))) + raise(Error(loc, val_env, No_overriding("method", lab.txt))) end; let (_, ty) = Ctype.filter_self_method val_env lab.txt priv meths self_type @@ -626,7 +629,8 @@ let rec class_field self_loc cl_num self_type meths vars end | _ -> assert false with Ctype.Unify trace -> - raise(Error(loc, Field_type_mismatch ("method", lab.txt, trace))) + raise(Error(loc, val_env, + Field_type_mismatch ("method", lab.txt, trace))) end; let meth_expr = make_method self_loc cl_num expr in (* backup variables for Pexp_override *) @@ -700,7 +704,7 @@ and class_structure cl_num final val_env met_env loc else self_type in begin try Ctype.unify val_env public_self ty with Ctype.Unify _ -> - raise(Error(spat.ppat_loc, Pattern_type_clash public_self)) + raise(Error(spat.ppat_loc, val_env, Pattern_type_clash public_self)) end; let get_methods ty = (fst (Ctype.flatten_fields @@ -743,7 +747,7 @@ and class_structure cl_num final val_env met_env loc (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l) sign.cty_vars [] in if mets <> [] || vals <> [] then - raise(Error(loc, Virtual_class(true, mets, vals))); + raise(Error(loc, val_env, Virtual_class(true, mets, vals))); let self_methods = List.fold_right (fun (lab,kind,ty) rem -> @@ -759,7 +763,7 @@ and class_structure cl_num final val_env met_env loc Ctype.unify val_env private_self (Ctype.newty (Tobject(self_methods, ref None))); Ctype.unify val_env public_self self_type - with Ctype.Unify trace -> raise(Error(loc, Final_self_clash trace)) + with Ctype.Unify trace -> raise(Error(loc, val_env, Final_self_clash trace)) end; end; @@ -794,7 +798,7 @@ and class_expr cl_num val_env met_env scl = Pcl_constr (lid, styl) -> let (path, decl) = Typetexp.find_class val_env scl.pcl_loc lid.txt in if Path.same decl.cty_path unbound_class then - raise(Error(scl.pcl_loc, Unbound_class_2 lid.txt)); + raise(Error(scl.pcl_loc, val_env, Unbound_class_2 lid.txt)); let tyl = List.map (fun sty -> transl_simple_type val_env false sty) styl @@ -804,14 +808,14 @@ and class_expr cl_num val_env met_env scl = in let clty' = abbreviate_class_type path params clty in if List.length params <> List.length tyl then - raise(Error(scl.pcl_loc, + raise(Error(scl.pcl_loc, val_env, Parameter_arity_mismatch (lid.txt, List.length params, List.length tyl))); List.iter2 (fun cty' ty -> let ty' = cty'.ctyp_type in try Ctype.unify val_env ty' ty with Ctype.Unify trace -> - raise(Error(cty'.ctyp_loc, Parameter_mismatch trace))) + raise(Error(cty'.ctyp_loc, val_env, Parameter_mismatch trace))) tyl params; let cl = rc {cl_desc = Tcl_ident (path, lid, tyl); @@ -934,10 +938,11 @@ and class_expr cl_num val_env met_env scl = if ignore_labels && not (Btype.is_optional l) then begin match sargs, more_sargs with (l', sarg0)::_, _ -> - raise(Error(sarg0.pexp_loc, Apply_wrong_label(l'))) + raise(Error(sarg0.pexp_loc, val_env, Apply_wrong_label l')) | _, (l', sarg0)::more_sargs -> if l <> l' && l' <> "" then - raise(Error(sarg0.pexp_loc, Apply_wrong_label l')) + raise(Error(sarg0.pexp_loc, val_env, + Apply_wrong_label l')) else ([], more_sargs, Some (type_argument val_env sarg0 ty ty)) | _ -> @@ -974,9 +979,9 @@ and class_expr cl_num val_env met_env scl = match sargs @ more_sargs with (l, sarg0)::_ -> if omitted <> [] then - raise(Error(sarg0.pexp_loc, Apply_wrong_label l)) + raise(Error(sarg0.pexp_loc, val_env, Apply_wrong_label l)) else - raise(Error(cl.cl_loc, Cannot_apply cl.cl_type)) + raise(Error(cl.cl_loc, val_env, Cannot_apply cl.cl_type)) | [] -> (List.rev args, List.fold_left @@ -998,7 +1003,7 @@ and class_expr cl_num val_env met_env scl = try Typecore.type_let val_env rec_flag sdefs None with Ctype.Unify [(ty, _)] -> - raise(Error(scl.pcl_loc, Make_nongen_seltype ty)) + raise(Error(scl.pcl_loc, val_env, Make_nongen_seltype ty)) in let (vals, met_env) = List.fold_right @@ -1054,7 +1059,7 @@ and class_expr cl_num val_env met_env scl = Includeclass.class_types val_env cl.cl_type clty.cltyp_type with [] -> () - | error -> raise(Error(cl.cl_loc, Class_match_failure error)) + | error -> raise(Error(cl.cl_loc, val_env, Class_match_failure error)) end; let (vals, meths, concrs) = extract_constraints clty.cltyp_type in rc {cl_desc = Tcl_constraint (cl, Some clty, vals, meths, concrs); @@ -1174,7 +1179,7 @@ let class_infos define_class kind let params, loc = cl.pci_params in List.map (fun x -> enter_type_variable true loc x.txt) params with Already_bound -> - raise(Error(snd cl.pci_params, Repeated_parameter)) + raise(Error(snd cl.pci_params, env, Repeated_parameter)) in (* Allow self coercions (only for class declarations) *) @@ -1212,7 +1217,7 @@ let class_infos define_class kind begin try List.iter2 (Ctype.unify env) obj_params obj_params' with Ctype.Unify _ -> - raise(Error(cl.pci_loc, + raise(Error(cl.pci_loc, env, Bad_parameters (obj_id, constr, Ctype.newconstr (Path.Pident obj_id) obj_params'))) @@ -1220,7 +1225,7 @@ let class_infos define_class kind begin try Ctype.unify env ty constr with Ctype.Unify _ -> - raise(Error(cl.pci_loc, + raise(Error(cl.pci_loc, env, Abbrev_type_clash (constr, ty, Ctype.expand_head env constr))) end end; @@ -1234,7 +1239,7 @@ let class_infos define_class kind begin try List.iter2 (Ctype.unify env) cl_params cl_params' with Ctype.Unify _ -> - raise(Error(cl.pci_loc, + raise(Error(cl.pci_loc, env, Bad_parameters (cl_id, Ctype.newconstr (Path.Pident cl_id) cl_params, @@ -1245,7 +1250,7 @@ let class_infos define_class kind Ctype.unify env ty cl_ty with Ctype.Unify _ -> let constr = Ctype.newconstr (Path.Pident cl_id) params in - raise(Error(cl.pci_loc, Abbrev_type_clash (constr, ty, cl_ty))) + raise(Error(cl.pci_loc, env, Abbrev_type_clash (constr, ty, cl_ty))) end end; @@ -1255,7 +1260,7 @@ let class_infos define_class kind (constructor_type constr obj_type) (Ctype.instance env constr_type) with Ctype.Unify trace -> - raise(Error(cl.pci_loc, + raise(Error(cl.pci_loc, env, Constructor_type_mismatch (cl.pci_name.txt, trace))) end; @@ -1288,7 +1293,7 @@ let class_infos define_class kind (fun name (mut, vr, ty) l -> if vr = Virtual then name :: l else l) sign.cty_vars [] in if mets <> [] || vals <> [] then - raise(Error(cl.pci_loc, Virtual_class(true, mets, vals))); + raise(Error(cl.pci_loc, env, Virtual_class(true, mets, vals))); end; (* Misc. *) @@ -1350,7 +1355,7 @@ let final_decl env define_class begin try Ctype.collapse_conj_params env clty.cty_params with Ctype.Unify trace -> - raise(Error(cl.pci_loc, Non_collapsable_conjunction (id, clty, trace))) + raise(Error(cl.pci_loc, env, Non_collapsable_conjunction (id, clty, trace))) end; List.iter Ctype.generalize clty.cty_params; @@ -1371,7 +1376,7 @@ let final_decl env define_class end; if not (closed_class clty) then - raise(Error(cl.pci_loc, Non_generalizable_class (id, clty))); + raise(Error(cl.pci_loc, env, Non_generalizable_class (id, clty))); begin match Ctype.closed_class clty.cty_params @@ -1384,7 +1389,7 @@ let final_decl env define_class then function ppf -> Printtyp.class_declaration id ppf clty else function ppf -> Printtyp.cltype_declaration id ppf cltydef in - raise(Error(cl.pci_loc, Unbound_type_var(printer, reason))) + raise(Error(cl.pci_loc, env, Unbound_type_var(printer, reason))) end; (id, cl.pci_name, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, @@ -1447,10 +1452,10 @@ let check_coercions env in begin try Ctype.subtype env cl_ty obj_ty () with Ctype.Subtype (tr1, tr2) -> - raise(Typecore.Error(loc, Typecore.Not_subtype(tr1, tr2))) + raise(Typecore.Error(loc, env, Typecore.Not_subtype(tr1, tr2))) end; if not (Ctype.opened_object cl_ty) then - raise(Error(loc, Cannot_coerce_self obj_ty)) + raise(Error(loc, env, Cannot_coerce_self obj_ty)) end; (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, arity, pub_meths, req) @@ -1568,16 +1573,16 @@ let approx_class_declarations env sdecls = open Format -let report_error ppf = function +let report_error env ppf = function | Repeated_parameter -> fprintf ppf "A type parameter occurs several times" | Unconsistent_constraint trace -> fprintf ppf "The class constraints are not consistent.@."; - Printtyp.report_unification_error ppf trace + Printtyp.report_unification_error ppf env trace (fun ppf -> fprintf ppf "Type") (fun ppf -> fprintf ppf "is not compatible with type") | Field_type_mismatch (k, m, trace) -> - Printtyp.report_unification_error ppf trace + Printtyp.report_unification_error ppf env trace (function ppf -> fprintf ppf "The %s %s@ has type" k m) (function ppf -> @@ -1616,7 +1621,7 @@ let report_error ppf = function Printtyp.type_expr actual Printtyp.type_expr expected | Constructor_type_mismatch (c, trace) -> - Printtyp.report_unification_error ppf trace + Printtyp.report_unification_error ppf env trace (function ppf -> fprintf ppf "The expression \"new %s\" has type" c) (function ppf -> @@ -1641,7 +1646,7 @@ let report_error ppf = function but is here applied to %i type argument(s)@]" Printtyp.longident lid expected provided | Parameter_mismatch trace -> - Printtyp.report_unification_error ppf trace + Printtyp.report_unification_error ppf env trace (function ppf -> fprintf ppf "The type parameter") (function ppf -> @@ -1698,11 +1703,11 @@ let report_error ppf = function "@[The type of this class,@ %a,@ \ contains non-collapsible conjunctive types in constraints@]" (Printtyp.class_declaration id) clty; - Printtyp.report_unification_error ppf trace + Printtyp.report_unification_error ppf env trace (fun ppf -> fprintf ppf "Type") (fun ppf -> fprintf ppf "is not compatible with type") | Final_self_clash trace -> - Printtyp.report_unification_error ppf trace + Printtyp.report_unification_error ppf env trace (function ppf -> fprintf ppf "This object is expected to have type") (function ppf -> @@ -1719,3 +1724,6 @@ let report_error ppf = function "instance variable" | No_overriding (kind, name) -> fprintf ppf "@[The %s `%s'@ has no previous definition@]" kind name + +let report_error env ppf err = + Printtyp.wrap_printing_env env (fun () -> report_error env ppf err) diff --git a/typing/typeclass.mli b/typing/typeclass.mli index 19a0a2aad8..c8f28013d6 100644 --- a/typing/typeclass.mli +++ b/typing/typeclass.mli @@ -104,6 +104,6 @@ type error = | Mutability_mismatch of string * mutable_flag | No_overriding of string * string -exception Error of Location.t * error +exception Error of Location.t * Env.t * error -val report_error : formatter -> error -> unit +val report_error : Env.t -> formatter -> error -> unit diff --git a/typing/typecore.ml b/typing/typecore.ml index 7943420587..f082484947 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -33,7 +33,7 @@ type error = | Label_multiply_defined of string | Label_missing of Ident.t list | Label_not_mutable of Longident.t - | Wrong_name of string * Env.t * Path.t * Longident.t + | Wrong_name of string * Path.t * Longident.t | Name_type_mismatch of string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list | Incomplete_format of string @@ -64,7 +64,7 @@ type error = | Unexpected_existential | Unqualified_gadt_pattern of Path.t * string -exception Error of Location.t * error +exception Error of Location.t * Env.t * error (* Forward declaration, to be filled in by Typemod.type_module *) @@ -271,9 +271,9 @@ let unify_pat_types loc env ty ty' = unify env ty ty' with Unify trace -> - raise(Error(loc, Pattern_type_clash(trace))) + raise(Error(loc, env, Pattern_type_clash(trace))) | Tags(l1,l2) -> - raise(Typetexp.Error(loc, Typetexp.Variant_tags (l1, l2))) + raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2))) (* unification inside type_exp and type_expect *) let unify_exp_types loc env ty expected_ty = @@ -283,9 +283,9 @@ let unify_exp_types loc env ty expected_ty = unify env ty expected_ty with Unify trace -> - raise(Error(loc, Expr_type_clash(trace))) + raise(Error(loc, env, Expr_type_clash(trace))) | Tags(l1,l2) -> - raise(Typetexp.Error(loc, Typetexp.Variant_tags (l1, l2))) + raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2))) (* level at which to create the local type declarations *) let newtype_level = ref None @@ -304,11 +304,11 @@ let unify_pat_types_gadt loc env ty ty' = unify_gadt ~newtype_level env ty ty' with Unify trace -> - raise(Error(loc, Pattern_type_clash(trace))) + raise(Error(loc, !env, Pattern_type_clash(trace))) | Tags(l1,l2) -> - raise(Typetexp.Error(loc, Typetexp.Variant_tags (l1, l2))) + raise(Typetexp.Error(loc, !env, Typetexp.Variant_tags (l1, l2))) | Unification_recursive_abbrev trace -> - raise(Error(loc, Recursive_local_constraint trace)) + raise(Error(loc, !env, Recursive_local_constraint trace)) (* Creating new conjunctive types is not allowed when typing patterns *) @@ -375,13 +375,14 @@ let reset_pattern scope allow = let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty = if List.exists (fun (id, _, _, _, _) -> Ident.name id = name.txt) !pattern_variables - then raise(Error(loc, Multiply_bound_variable name.txt)); + then raise(Error(loc, Env.empty, Multiply_bound_variable name.txt)); let id = Ident.create name.txt in pattern_variables := (id, ty, name, loc, is_as_variable) :: !pattern_variables; if is_module then begin (* Note: unpack patterns enter a variable of the same name *) - if not !allow_modules then raise (Error (loc, Modules_not_allowed)); + if not !allow_modules then + raise (Error (loc, Env.empty, Modules_not_allowed)); module_variables := (name, loc) :: !module_variables end else (* moved to genannot *) @@ -410,18 +411,18 @@ let enter_orpat_variables loc env p1_vs p2_vs = unify env t1 t2 with | Unify trace -> - raise(Error(loc, Pattern_type_clash(trace))) + raise(Error(loc, env, Pattern_type_clash(trace))) end; (x2,x1)::unify_vars rem1 rem2 end | [],[] -> [] - | (x,_,_,_,_)::_, [] -> raise (Error (loc, Orpat_vars x)) - | [],(x,_,_,_,_)::_ -> raise (Error (loc, Orpat_vars x)) + | (x,_,_,_,_)::_, [] -> raise (Error (loc, env, Orpat_vars x)) + | [],(x,_,_,_,_)::_ -> raise (Error (loc, env, Orpat_vars x)) | (x,_,_,_,_)::_, (y,_,_,_,_)::_ -> let min_var = if Ident.name x < Ident.name y then x else y in - raise (Error (loc, Orpat_vars min_var)) in + raise (Error (loc, env, Orpat_vars min_var)) in unify_vars p1_vs p2_vs let rec build_as_type env p = @@ -485,7 +486,7 @@ let build_or_pat env loc lid = let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in match ty.desc with Tvariant row when static_row row -> row - | _ -> raise(Error(loc, Not_a_variant_type lid)) + | _ -> raise(Error(loc, env, Not_a_variant_type lid)) in let pats, fields = List.fold_left @@ -514,7 +515,7 @@ let build_or_pat env loc lid = pats in match pats with - [] -> raise(Error(loc, Not_a_variant_type lid)) + [] -> raise(Error(loc, env, Not_a_variant_type lid)) | pat :: pats -> let r = List.fold_left @@ -572,7 +573,7 @@ end) = struct try List.find (fun nd -> get_name nd = s) descrs with Not_found -> - raise (Error (lid.loc, Wrong_name (type_kind, env, tpath, lid.txt))) + raise (Error (lid.loc, env, Wrong_name (type_kind, tpath, lid.txt))) end | _ -> raise Not_found @@ -648,7 +649,7 @@ end) = struct (tp0, tp)) lbls in - raise (Error (lid.loc, + raise (Error (lid.loc, env, Name_type_mismatch (type_kind, lid.txt, tp, tpl))) end @@ -771,7 +772,7 @@ let check_recordpat_labels loc lbl_pat_list closed = let defined = Array.make (Array.length all) false in let check_defined (_, label, _) = if defined.(label.lbl_pos) - then raise(Error(loc, Label_multiply_defined label.lbl_name)) + then raise(Error(loc, Env.empty, Label_multiply_defined label.lbl_name)) else defined.(label.lbl_pos) <- true in List.iter check_defined lbl_pat_list; if closed = Closed @@ -920,14 +921,14 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = in let check_lk tpath constr = if constr.cstr_generalized then - raise (Error (lid.loc, + raise (Error (lid.loc, !env, Unqualified_gadt_pattern (tpath, constr.cstr_name))) in let constr = Constructor.disambiguate lid !env opath constrs ~check_lk in Env.mark_constructor Env.Pattern !env (Longident.last lid.txt) constr; if no_existentials && constr.cstr_existentials <> [] then - raise (Error (loc, Unexpected_existential)); + raise (Error (loc, !env, Unexpected_existential)); (* if constructor is gadt, we must verify that the expected type has the correct head *) if constr.cstr_generalized then @@ -944,7 +945,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = replicate_list sp constr.cstr_arity | Some sp -> [sp] in if List.length sargs <> constr.cstr_arity then - raise(Error(loc, Constructor_arity_mismatch(lid.txt, + raise(Error(loc, !env, Constructor_arity_mismatch(lid.txt, constr.cstr_arity, List.length sargs))); let (ty_args, ty_res) = instance_constructor ~in_pattern:(env, get_newtype_level ()) constr @@ -989,7 +990,8 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = begin try unify_pat_types loc !env ty_res record_ty with Unify trace -> - raise(Error(label_lid.loc, Label_mismatch(label_lid.txt, trace))) + raise(Error(label_lid.loc, !env, + Label_mismatch(label_lid.txt, trace))) end; let arg = type_pat sarg ty_arg in if vars <> [] then begin @@ -1000,7 +1002,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = let tv = expand_head !env tv in not (is_Tvar tv) || tv.level <> generic_level in if List.exists instantiated vars then - raise (Error(label_lid.loc, Polymorphic_label label_lid.txt)) + raise (Error(label_lid.loc, !env, Polymorphic_label label_lid.txt)) end; (label_lid, label, arg) in @@ -1338,9 +1340,9 @@ let type_format loc fmt = let ty_arrow gty ty = newty (Tarrow ("", instance_def gty, ty, Cok)) in let bad_conversion fmt i c = - raise (Error (loc, Bad_conversion (fmt, i, c))) in + raise (Error (loc, Env.empty, Bad_conversion (fmt, i, c))) in let incomplete_format fmt = - raise (Error (loc, Incomplete_format fmt)) in + raise (Error (loc, Env.empty, Incomplete_format fmt)) in let rec type_in_format fmt = @@ -1568,7 +1570,7 @@ let rec type_approx env sexp = and ty1 = approx_ty_opt sty1 and ty2 = approx_ty_opt sty2 in begin try unify env ty ty1 with Unify trace -> - raise(Error(sexp.pexp_loc, Expr_type_clash trace)) + raise(Error(sexp.pexp_loc, env, Expr_type_clash trace)) end; if sty2 = None then ty1 else ty2 | _ -> newvar () @@ -1606,7 +1608,7 @@ let check_univars env expans kind exp ty_expected vars = if List.length vars = List.length vars' then () else let ty = newgenty (Tpoly(repr exp.exp_type, vars')) and ty_expected = repr ty_expected in - raise (Error (exp.exp_loc, + raise (Error (exp.exp_loc, env, Less_general(kind, [ty, ty; ty_expected, ty_expected]))) (* Check that a type is not a function *) @@ -1815,7 +1817,7 @@ and type_expect_ ?in_function env sexp ty_expected = in Texp_ident(path, lid, desc) | Val_unbound -> - raise(Error(loc, Masked_instance_variable lid.txt)) + raise(Error(loc, env, Masked_instance_variable lid.txt)) | _ -> Texp_ident(path, lid, desc) end; @@ -1915,9 +1917,9 @@ and type_expect_ ?in_function env sexp ty_expected = with Unify _ -> match expand_head env ty_expected with {desc = Tarrow _} as ty -> - raise(Error(loc, Abstract_wrong_label(l, ty))) + raise(Error(loc, env, Abstract_wrong_label(l, ty))) | _ -> - raise(Error(loc_fun, + raise(Error(loc_fun, env, Too_many_arguments (in_function <> None, ty_fun))) in let ty_arg = @@ -2092,7 +2094,7 @@ and type_expect_ ?in_function env sexp ty_expected = type_label_a_list directly *) let rec check_duplicates = function | (_, lbl1, _) :: (_, lbl2, _) :: _ when lbl1.lbl_pos = lbl2.lbl_pos -> - raise(Error(loc, Label_multiply_defined lbl1.lbl_name)) + raise(Error(loc, env, Label_multiply_defined lbl1.lbl_name)) | _ :: rem -> check_duplicates rem | [] -> () @@ -2133,7 +2135,7 @@ and type_expect_ ?in_function env sexp ty_expected = else lbl :: missing_labels (n + 1) rem in let missing = missing_labels 0 label_names in - raise(Error(loc, Label_missing missing)) + raise(Error(loc, env, Label_missing missing)) end else if opt_sexp <> None && List.length lid_sexp_list = num_fields then Location.prerr_warning loc Warnings.Useless_record_with; @@ -2158,7 +2160,7 @@ and type_expect_ ?in_function env sexp ty_expected = type_label_exp false env loc ty_record (lid, label, snewval) in unify_exp env record ty_record; if label.lbl_mut = Immutable then - raise(Error(loc, Label_not_mutable lid.txt)); + raise(Error(loc, env, Label_not_mutable lid.txt)); rue { exp_desc = Texp_setfield(record, label_loc, label, newval); exp_loc = loc; exp_extra = []; @@ -2284,13 +2286,13 @@ and type_expect_ ?in_function env sexp ty_expected = (Warnings.Not_principal "this ground coercion"); with Subtype (tr1, tr2) -> (* prerr_endline "coercion failed"; *) - raise(Error(loc, Not_subtype(tr1, tr2))) + raise(Error(loc, env, Not_subtype(tr1, tr2))) end; | _ -> let ty, b = enlarge_type env ty' in force (); begin try Ctype.unify env arg.exp_type ty with Unify trace -> - raise(Error(sarg.pexp_loc, + raise(Error(sarg.pexp_loc, env, Coercion_failure(ty', full_expand env ty', trace, b))) end end; @@ -2308,7 +2310,7 @@ and type_expect_ ?in_function env sexp ty_expected = let force'' = subtype env ty ty' in force (); force' (); force'' () with Subtype (tr1, tr2) -> - raise(Error(loc, Not_subtype(tr1, tr2))) + raise(Error(loc, env, Not_subtype(tr1, tr2))) end; if separate then begin end_def (); @@ -2351,7 +2353,7 @@ and type_expect_ ?in_function env sexp ty_expected = | Texp_ident(path, lid, {val_kind = Val_anc (methods, cl_num)}) -> let method_id = begin try List.assoc met methods with Not_found -> - raise(Error(e.pexp_loc, Undefined_inherited_method met)) + raise(Error(e.pexp_loc, env, Undefined_inherited_method met)) end in begin match @@ -2422,13 +2424,13 @@ and type_expect_ ?in_function env sexp ty_expected = exp_type = typ; exp_env = env } with Unify _ -> - raise(Error(e.pexp_loc, Undefined_method (obj.exp_type, met))) + raise(Error(e.pexp_loc, env, Undefined_method (obj.exp_type, met))) end | Pexp_new cl -> let (cl_path, cl_decl) = Typetexp.find_class env loc cl.txt in begin match cl_decl.cty_new with None -> - raise(Error(loc, Virtual_class cl.txt)) + raise(Error(loc, env, Virtual_class cl.txt)) | Some ty -> rue { exp_desc = Texp_new (cl_path, cl, cl_decl); @@ -2452,19 +2454,19 @@ and type_expect_ ?in_function env sexp ty_expected = exp_type = instance_def Predef.type_unit; exp_env = env } | Val_ivar _ -> - raise(Error(loc,Instance_variable_not_mutable(true,lab.txt))) + raise(Error(loc, env, Instance_variable_not_mutable(true,lab.txt))) | _ -> - raise(Error(loc,Instance_variable_not_mutable(false,lab.txt))) + raise(Error(loc, env, Instance_variable_not_mutable(false,lab.txt))) with Not_found -> - raise(Error(loc, Unbound_instance_variable lab.txt)) + raise(Error(loc, env, Unbound_instance_variable lab.txt)) end | Pexp_override lst -> let _ = List.fold_right (fun (lab, _) l -> if List.exists (fun l -> l.txt = lab.txt) l then - raise(Error(loc, + raise(Error(loc, env, Value_multiply_overridden lab.txt)); lab::l) lst @@ -2474,7 +2476,7 @@ and type_expect_ ?in_function env sexp ty_expected = Env.lookup_value (Longident.Lident "selfpat-*") env, Env.lookup_value (Longident.Lident "self-*") env with Not_found -> - raise(Error(loc, Outside_class)) + raise(Error(loc, env, Outside_class)) with (_, {val_type = self_ty; val_kind = Val_self (_, vars, _, _)}), (path_self, _) -> @@ -2484,7 +2486,7 @@ and type_expect_ ?in_function env sexp ty_expected = (Path.Pident id, lab, type_expect env snewval (instance env ty)) with Not_found -> - raise(Error(loc, Unbound_instance_variable lab.txt)) + raise(Error(loc, env, Unbound_instance_variable lab.txt)) end in let modifs = List.map type_override lst in @@ -2517,7 +2519,7 @@ and type_expect_ ?in_function env sexp ty_expected = begin try Ctype.unify_var new_env ty body.exp_type with Unify _ -> - raise(Error(loc, Scoping_let_module(name.txt, body.exp_type))) + raise(Error(loc, env, Scoping_let_module(name.txt, body.exp_type))) end; re { exp_desc = Texp_letmodule(id, name, modl, body); @@ -2654,9 +2656,9 @@ and type_expect_ ?in_function env sexp ty_expected = (Warnings.Not_principal "this module packing"); (p, nl, tl) | {desc = Tvar _} -> - raise (Error (loc, Cannot_infer_signature)) + raise (Error (loc, env, Cannot_infer_signature)) | _ -> - raise (Error (loc, Not_a_packed_module ty_expected)) + raise (Error (loc, env, Not_a_packed_module ty_expected)) in let (modl, tl') = !type_package env m p nl tl in rue { @@ -2705,7 +2707,7 @@ and type_label_exp create env loc ty_expected begin try unify env (instance_def ty_res) (instance env ty_expected) with Unify trace -> - raise (Error(lid.loc, Label_mismatch(lid.txt, trace))) + raise (Error(lid.loc, env, Label_mismatch(lid.txt, trace))) end; (* Instantiate so that we can generalize internal nodes *) let ty_arg = instance_def ty_arg in @@ -2716,9 +2718,9 @@ and type_label_exp create env loc ty_expected end; if label.lbl_private = Private then if create then - raise (Error(loc, Private_type ty_expected)) + raise (Error(loc, env, Private_type ty_expected)) else - raise (Error(lid.loc, Private_label(lid.txt, ty_expected))); + raise (Error(lid.loc, env, Private_label(lid.txt, ty_expected))); let arg = let snap = if vars = [] then None else Some (Btype.snapshot ()) in let arg = type_argument env sarg ty_arg (instance env ty_arg) in @@ -2736,7 +2738,7 @@ and type_label_exp create env loc ty_expected unify_exp env arg ty_arg; check_univars env false "field value" arg label.lbl_arg vars; arg - with Error (_, Less_general _) as e -> raise e + with Error (_, _, Less_general _) as e -> raise e | _ -> raise exn (* In case of failure return the first error *) in (lid, label, {arg with exp_type = instance env arg.exp_type}) @@ -2865,11 +2867,12 @@ and type_application env funct sargs = match ty_res.desc with Tarrow _ -> if (!Clflags.classic || not (has_label l1 ty_fun)) then - raise(Error(sarg1.pexp_loc, Apply_wrong_label(l1, ty_res))) + raise (Error(sarg1.pexp_loc, env, + Apply_wrong_label(l1, ty_res))) else - raise(Error(funct.exp_loc, Incoherent_label_order)) + raise (Error(funct.exp_loc, env, Incoherent_label_order)) | _ -> - raise(Error(funct.exp_loc, Apply_non_function + raise(Error(funct.exp_loc, env, Apply_non_function (expand_head env funct.exp_type))) in let optional = if is_optional l1 then Optional else Required in @@ -2914,10 +2917,12 @@ and type_application env funct sargs = (* In classic mode, omitted = [] *) match sargs, more_sargs with (l', sarg0) :: _, _ -> - raise(Error(sarg0.pexp_loc, Apply_wrong_label(l', ty_old))) + raise(Error(sarg0.pexp_loc, env, + Apply_wrong_label(l', ty_old))) | _, (l', sarg0) :: more_sargs -> if l <> l' && l' <> "" then - raise(Error(sarg0.pexp_loc, Apply_wrong_label(l', ty_fun'))) + raise(Error(sarg0.pexp_loc, env, + Apply_wrong_label(l', ty_fun'))) else ([], more_sargs, Some (fun () -> type_argument env sarg0 ty ty0)) @@ -2941,7 +2946,7 @@ and type_application env funct sargs = in sargs, more_sargs, if optional = Required && is_optional l' then - raise(Error(sarg0.pexp_loc, Apply_wrong_label(l', ty_fun'))) + raise(Error(sarg0.pexp_loc, env, Apply_wrong_label(l', ty_fun'))) else if optional = Required || is_optional l' then Some (fun () -> type_argument env sarg0 ty ty0) else begin @@ -2974,7 +2979,8 @@ and type_application env funct sargs = | _ -> match sargs with (l, sarg0) :: _ when ignore_labels -> - raise(Error(sarg0.pexp_loc, Apply_wrong_label(l, ty_old))) + raise(Error(sarg0.pexp_loc, env, + Apply_wrong_label(l, ty_old))) | _ -> type_unknown_args args omitted ty_fun0 (sargs @ more_sargs) @@ -3017,7 +3023,7 @@ and type_construct env loc lid sarg explicit_arity ty_expected = | Some {pexp_desc = Pexp_tuple sel} when constr.cstr_arity > 1 -> sel | Some se -> [se] in if List.length sargs <> constr.cstr_arity then - raise(Error(loc, Constructor_arity_mismatch + raise(Error(loc, env, Constructor_arity_mismatch (lid.txt, constr.cstr_arity, List.length sargs))); let separate = !Clflags.principal || Env.has_local_constraints env in if separate then (begin_def (); begin_def ()); @@ -3047,7 +3053,7 @@ and type_construct env loc lid sarg explicit_arity ty_expected = let args = List.map2 (fun e (t,t0) -> type_argument env e t t0) sargs (List.combine ty_args ty_args0) in if constr.cstr_private = Private then - raise(Error(loc, Private_type ty_res)); + raise(Error(loc, env, Private_type ty_res)); { texp with exp_desc = Texp_construct(lid, constr, args, explicit_arity) } @@ -3404,7 +3410,7 @@ let type_expression env sexp = open Format open Printtyp -let report_error ppf = function +let report_error env ppf = function | Polymorphic_label lid -> fprintf ppf "@[The record field %a is polymorphic.@ %s@]" longident lid "You cannot instantiate it in a pattern." @@ -3414,14 +3420,14 @@ let report_error ppf = function but is applied here to %i argument(s)@]" longident lid expected provided | Label_mismatch(lid, trace) -> - report_unification_error ppf trace + report_unification_error ppf env trace (function ppf -> fprintf ppf "The record field %a@ belongs to the type" longident lid) (function ppf -> fprintf ppf "but is mixed here with fields of type") | Pattern_type_clash trace -> - report_unification_error ppf trace + report_unification_error ppf env trace (function ppf -> fprintf ppf "This pattern matches values of type") (function ppf -> @@ -3432,7 +3438,7 @@ let report_error ppf = function fprintf ppf "Variable %s must occur on both sides of this | pattern" (Ident.name id) | Expr_type_clash trace -> - report_unification_error ppf trace + report_unification_error ppf env trace (function ppf -> fprintf ppf "This expression has type") (function ppf -> @@ -3470,7 +3476,7 @@ let report_error ppf = function print_labels labels | Label_not_mutable lid -> fprintf ppf "The record field %a is not mutable" longident lid - | Wrong_name (kind, env, p, lid) -> + | Wrong_name (kind, p, lid) -> fprintf ppf "The %s type %a has no %s %a" kind path p (if kind = "record" then "field" else "constructor") longident lid; @@ -3478,7 +3484,7 @@ let report_error ppf = function else Constructor.spellcheck ppf env p lid | Name_type_mismatch (kind, lid, tp, tpl) -> let name = if kind = "record" then "field" else "constructor" in - report_ambiguous_type_error ppf tp tpl + report_ambiguous_type_error ppf env tp tpl (function ppf -> fprintf ppf "The %s %a@ belongs to the %s type" name longident lid kind) @@ -3512,13 +3518,13 @@ let report_error ppf = function else fprintf ppf "The value %s is not an instance variable" v | Not_subtype(tr1, tr2) -> - report_subtyping_error ppf tr1 "is not a subtype of" tr2 + report_subtyping_error ppf env tr1 "is not a subtype of" tr2 | Outside_class -> fprintf ppf "This object duplication occurs outside a method definition" | Value_multiply_overridden v -> fprintf ppf "The instance variable %s is overridden several times" v | Coercion_failure (ty, ty', trace, b) -> - report_unification_error ppf trace + report_unification_error ppf env trace (function ppf -> let ty, ty' = prepare_expansion (ty, ty') in fprintf ppf @@ -3571,7 +3577,7 @@ let report_error ppf = function fprintf ppf "in an order different from other calls.@ "; fprintf ppf "This is only allowed when the real type is known." | Less_general (kind, trace) -> - report_unification_error ppf trace + report_unification_error ppf env trace (fun ppf -> fprintf ppf "This %s has type" kind) (fun ppf -> fprintf ppf "which is less general than") | Modules_not_allowed -> @@ -3584,7 +3590,7 @@ let report_error ppf = function "This expression is packed module, but the expected type is@ %a" type_expr ty | Recursive_local_constraint trace -> - report_unification_error ppf trace + report_unification_error ppf env trace (function ppf -> fprintf ppf "Recursive local constraint when unifying") (function ppf -> @@ -3597,5 +3603,8 @@ let report_error ppf = function name path tpath "must be qualified in this pattern" +let report_error env ppf err = + wrap_printing_env env (fun () -> report_error env ppf err) + let () = Env.add_delayed_check_forward := add_delayed_check diff --git a/typing/typecore.mli b/typing/typecore.mli index b60a963499..49897558de 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -75,7 +75,7 @@ type error = | Label_multiply_defined of string | Label_missing of Ident.t list | Label_not_mutable of Longident.t - | Wrong_name of string * Env.t * Path.t * Longident.t + | Wrong_name of string * Path.t * Longident.t | Name_type_mismatch of string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list | Incomplete_format of string @@ -106,9 +106,9 @@ type error = | Unexpected_existential | Unqualified_gadt_pattern of Path.t * string -exception Error of Location.t * error +exception Error of Location.t * Env.t * error -val report_error: formatter -> error -> unit +val report_error: Env.t -> formatter -> error -> unit (* Forward declaration, to be filled in by Typemod.type_module *) val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref diff --git a/typing/typedecl.ml b/typing/typedecl.ml index fc03264962..0c33986331 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -27,8 +27,8 @@ type error = | Recursive_abbrev of string | Definition_mismatch of type_expr * Includecore.type_mismatch list | Constraint_failed of type_expr * type_expr - | Inconsistent_constraint of (type_expr * type_expr) list - | Type_clash of (type_expr * type_expr) list + | Inconsistent_constraint of Env.t * (type_expr * type_expr) list + | Type_clash of Env.t * (type_expr * type_expr) list | Parameters_differ of Path.t * type_expr * type_expr | Null_arity_external | Missing_native_external @@ -72,7 +72,7 @@ let update_type temp_env env id loc = let params = List.map (fun _ -> Ctype.newvar ()) decl.type_params in try Ctype.unify env (Ctype.newconstr path params) ty with Ctype.Unify trace -> - raise (Error(loc, Type_clash trace)) + raise (Error(loc, Type_clash (env, trace))) (* Determine if a type is (an abbreviation for) the type "float" *) (* We use the Ctype.expand_head_opt version of expand_head to get access @@ -238,7 +238,7 @@ let transl_declaration env (name, sdecl) id = let ty = cty.ctyp_type in let ty' = cty'.ctyp_type in try Ctype.unify env ty ty' with Ctype.Unify tr -> - raise(Error(loc, Inconsistent_constraint tr))) + raise(Error(loc, Inconsistent_constraint (env, tr)))) cstrs; Ctype.end_def (); (* Add abstract row *) @@ -408,7 +408,7 @@ let check_well_founded env loc path decl = try Ctype.correct_abbrev env path decl.type_params body with | Ctype.Recursive_abbrev -> raise(Error(loc, Recursive_abbrev (Path.name path))) - | Ctype.Unify trace -> raise(Error(loc, Type_clash trace))) + | Ctype.Unify trace -> raise(Error(loc, Type_clash (env, trace)))) decl.type_manifest (* Check for ill-defined abbrevs *) @@ -946,7 +946,7 @@ let transl_with_constraint env id row_path orig_decl sdecl = Ctype.unify env ty ty'; (cty, cty', loc) with Ctype.Unify tr -> - raise(Error(loc, Inconsistent_constraint tr))) + raise(Error(loc, Inconsistent_constraint (env, tr)))) sdecl.ptype_cstrs in let no_row = not (is_fixed_type sdecl) in @@ -1097,13 +1097,13 @@ let report_error ppf = function fprintf ppf "@[<hv>In the definition of %s, type@ %a@ should be@ %a@]" (Path.name path) Printtyp.type_expr ty Printtyp.type_expr ty' - | Inconsistent_constraint trace -> + | Inconsistent_constraint (env, trace) -> fprintf ppf "The type constraints are not consistent.@."; - Printtyp.report_unification_error ppf trace + Printtyp.report_unification_error ppf env trace (fun ppf -> fprintf ppf "Type") (fun ppf -> fprintf ppf "is not compatible with type") - | Type_clash trace -> - Printtyp.report_unification_error ppf trace + | Type_clash (env, trace) -> + Printtyp.report_unification_error ppf env trace (function ppf -> fprintf ppf "This type constructor expands to type") (function ppf -> diff --git a/typing/typedecl.mli b/typing/typedecl.mli index 60d6b5797d..5b7a5d2036 100644 --- a/typing/typedecl.mli +++ b/typing/typedecl.mli @@ -62,8 +62,8 @@ type error = | Recursive_abbrev of string | Definition_mismatch of type_expr * Includecore.type_mismatch list | Constraint_failed of type_expr * type_expr - | Inconsistent_constraint of (type_expr * type_expr) list - | Type_clash of (type_expr * type_expr) list + | Inconsistent_constraint of Env.t * (type_expr * type_expr) list + | Type_clash of Env.t * (type_expr * type_expr) list | Parameters_differ of Path.t * type_expr * type_expr | Null_arity_external | Missing_native_external diff --git a/typing/typemod.ml b/typing/typemod.ml index fa8fba691d..a86e4bba23 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -38,7 +38,7 @@ type error = | Incomplete_packed_module of type_expr | Scoping_pack of Longident.t * type_expr -exception Error of Location.t * error +exception Error of Location.t * Env.t * error open Typedtree @@ -55,12 +55,12 @@ let rec path_concat head p = let extract_sig env loc mty = match Mtype.scrape env mty with Mty_signature sg -> sg - | _ -> raise(Error(loc, Signature_expected)) + | _ -> raise(Error(loc, env, Signature_expected)) let extract_sig_open env loc mty = match Mtype.scrape env mty with Mty_signature sg -> sg - | _ -> raise(Error(loc, Structure_expected mty)) + | _ -> raise(Error(loc, env, Structure_expected mty)) (* Compute the environment after opening a module *) @@ -119,7 +119,7 @@ let merge_constraint initial_env loc sg lid constr = let rec merge env sg namelist row_id = match (sg, namelist, constr) with ([], _, _) -> - raise(Error(loc, With_no_component lid.txt)) + raise(Error(loc, env, With_no_component lid.txt)) | (Sig_type(id, decl, rs) :: rem, [s], Pwith_type ({ptype_kind = Ptype_abstract} as sdecl)) when Ident.name id = s && Typedecl.is_fixed_type sdecl -> @@ -214,7 +214,8 @@ let merge_constraint initial_env loc sg lid constr = ) params sdecl.ptype_params; lid | _ -> raise Exit - with Exit -> raise (Error (sdecl.ptype_loc, With_need_typeconstr)) + with Exit -> + raise(Error(sdecl.ptype_loc, initial_env, With_need_typeconstr)) in let (path, _) = try Env.lookup_type lid.txt initial_env with Not_found -> assert false @@ -232,7 +233,7 @@ let merge_constraint initial_env loc sg lid constr = in (tcstr, sg) with Includemod.Error explanation -> - raise(Error(loc, With_mismatch(lid.txt, explanation))) + raise(Error(loc, initial_env, With_mismatch(lid.txt, explanation))) (* Add recursion flags on declarations arising from a mutually recursive block. *) @@ -242,11 +243,14 @@ let map_rec fn decls rem = | [] -> rem | d1 :: dl -> fn Trec_first d1 :: map_end (fn Trec_next) dl rem +let map_rec' = map_rec +(* let rec map_rec' fn decls rem = match decls with | (id,_ as d1) :: dl when Btype.is_row_name (Ident.name id) -> fn Trec_not d1 :: map_rec' fn dl rem | _ -> map_rec fn decls rem +*) let rec map_rec'' fn decls rem = match decls with @@ -356,7 +360,7 @@ module StringSet = Set.Make(struct type t = string let compare = compare end) let check cl loc set_ref name = if StringSet.mem name !set_ref - then raise(Error(loc, Repeated_name(cl, name))) + then raise(Error(loc, Env.empty, Repeated_name(cl, name))) else set_ref := StringSet.add name !set_ref let check_sig_item type_names module_names modtype_names loc = function @@ -641,11 +645,11 @@ let check_nongen_scheme env str = List.iter (fun (pat, exp) -> if not (Ctype.closed_schema exp.exp_type) then - raise(Error(exp.exp_loc, Non_generalizable exp.exp_type))) + raise(Error(exp.exp_loc, env, Non_generalizable exp.exp_type))) pat_exp_list | Tstr_module(id, _, md) -> if not (closed_modtype md.mod_type) then - raise(Error(md.mod_loc, Non_generalizable_module md.mod_type)) + raise(Error(md.mod_loc, env, Non_generalizable_module md.mod_type)) | _ -> () let check_nongen_schemes env str = @@ -752,7 +756,7 @@ let check_recmodule_inclusion env bindings = try Includemod.modtypes env mty_actual' mty_decl' with Includemod.Error msg -> - raise(Error(modl.mod_loc, Not_included msg)) in + raise(Error(modl.mod_loc, env, Not_included msg)) in let modl' = { mod_desc = Tmod_constraint(modl, mty_decl.mty_type, Tmodtype_explicit mty_decl, coercion); @@ -797,17 +801,17 @@ let modtype_of_package env loc p nl tl = (List.combine (List.map Longident.flatten nl) tl) | _ -> if nl = [] then Mty_ident p - else raise(Error(loc, Signature_expected)) + else raise(Error(loc, env, Signature_expected)) with Not_found -> - let error = Typetexp.Unbound_modtype (env, Ctype.lid_of_path p) in - raise(Typetexp.Error(loc, error)) + let error = Typetexp.Unbound_modtype (Ctype.lid_of_path p) in + raise(Typetexp.Error(loc, env, error)) let wrap_constraint env arg mty explicit = let coercion = try Includemod.modtypes env arg.mod_type mty with Includemod.Error msg -> - raise(Error(arg.mod_loc, Not_included msg)) in + raise(Error(arg.mod_loc, env, Not_included msg)) in { mod_desc = Tmod_constraint(arg, mty, explicit, coercion); mod_type = mty; mod_env = env; @@ -849,7 +853,7 @@ let rec type_module sttn funct_body anchor env smod = try Includemod.modtypes env arg.mod_type mty_param with Includemod.Error msg -> - raise(Error(sarg.pmod_loc, Not_included msg)) in + raise(Error(sarg.pmod_loc, env, Not_included msg)) in let mty_appl = match path with Some path -> @@ -860,7 +864,7 @@ let rec type_module sttn funct_body anchor env smod = Mtype.nondep_supertype (Env.add_module param arg.mod_type env) param mty_res with Not_found -> - raise(Error(smod.pmod_loc, + raise(Error(smod.pmod_loc, env, Cannot_eliminate_dependency mty_functor)) in rm { mod_desc = Tmod_apply(funct, arg, coercion); @@ -868,7 +872,7 @@ let rec type_module sttn funct_body anchor env smod = mod_env = env; mod_loc = smod.pmod_loc } | _ -> - raise(Error(sfunct.pmod_loc, Cannot_apply funct.mod_type)) + raise(Error(sfunct.pmod_loc, env, Cannot_apply funct.mod_type)) end | Pmod_constraint(sarg, smty) -> let arg = type_module true funct_body anchor env sarg in @@ -878,7 +882,7 @@ let rec type_module sttn funct_body anchor env smod = | Pmod_unpack sexp -> if funct_body then - raise (Error (smod.pmod_loc, Not_allowed_in_functor_body)); + raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body)); if !Clflags.principal then Ctype.begin_def (); let exp = Typecore.type_exp env sexp in if !Clflags.principal then begin @@ -889,7 +893,7 @@ let rec type_module sttn funct_body anchor env smod = match Ctype.expand_head env exp.exp_type with {desc = Tpackage (p, nl, tl)} -> if List.exists (fun t -> Ctype.free_variables t <> []) tl then - raise (Error (smod.pmod_loc, + raise (Error (smod.pmod_loc, env, Incomplete_packed_module exp.exp_type)); if !Clflags.principal && not (Typecore.generalizable (Btype.generic_level-1) exp.exp_type) @@ -899,9 +903,9 @@ let rec type_module sttn funct_body anchor env smod = modtype_of_package env smod.pmod_loc p nl tl | {desc = Tvar _} -> raise (Typecore.Error - (smod.pmod_loc, Typecore.Cannot_infer_signature)) + (smod.pmod_loc, env, Typecore.Cannot_infer_signature)) | _ -> - raise (Error (smod.pmod_loc, Not_a_packed_module exp.exp_type)) + raise (Error(smod.pmod_loc, env, Not_a_packed_module exp.exp_type)) in rm { mod_desc = Tmod_unpack(exp, mty); mod_type = mty; @@ -1192,7 +1196,7 @@ let type_module_type_of env smod = let mty = simplify_modtype mty in (* PR#5036: must not contain non-generalized type variables *) if not (closed_modtype mty) then - raise(Error(smod.pmod_loc, Non_generalizable_module mty)); + raise(Error(smod.pmod_loc, env, Non_generalizable_module mty)); tmty, mty (* For Typecore *) @@ -1235,7 +1239,8 @@ let type_package env m p nl tl = List.iter2 (fun n ty -> try Ctype.unify env ty (Ctype.newvar ()) - with Ctype.Unify _ -> raise (Error(m.pmod_loc, Scoping_pack (n,ty)))) + with Ctype.Unify _ -> + raise (Error(m.pmod_loc, env, Scoping_pack (n,ty)))) nl tl'; (wrap_constraint env modl mty Tmodtype_implicit, tl') @@ -1258,7 +1263,8 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = type_structure initial_env ast (Location.in_file sourcefile) in let simple_sg = simplify_signature sg in if !Clflags.print_types then begin - fprintf std_formatter "%a@." Printtyp.signature simple_sg; + Printtyp.wrap_printing_env initial_env + (fun () -> fprintf std_formatter "%a@." Printtyp.signature simple_sg); (str, Tcoerce_none) (* result is ignored by Compile.implementation *) end else begin let sourceintf = @@ -1268,7 +1274,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = try find_in_path_uncap !Config.load_path (modulename ^ ".cmi") with Not_found -> - raise(Error(Location.in_file sourcefile, + raise(Error(Location.in_file sourcefile, Env.empty, Interface_not_compiled sourceintf)) in let dclsig = Env.read_signature modulename intf_file in let coercion = Includemod.compunit sourcefile sg intf_file dclsig in @@ -1334,7 +1340,8 @@ let package_units objfiles cmifile modulename = let sg = Env.read_signature modname (pref ^ ".cmi") in if Filename.check_suffix f ".cmi" && not(Mtype.no_code_needed_sig Env.initial sg) - then raise(Error(Location.none, Implementation_is_required f)); + then raise(Error(Location.none, Env.empty, + Implementation_is_required f)); (modname, Env.read_signature modname (pref ^ ".cmi"))) objfiles in (* Compute signature of packaged unit *) @@ -1345,7 +1352,8 @@ let package_units objfiles cmifile modulename = let mlifile = prefix ^ !Config.interface_suffix in if Sys.file_exists mlifile then begin if not (Sys.file_exists cmifile) then begin - raise(Error(Location.in_file mlifile, Interface_not_compiled mlifile)) + raise(Error(Location.in_file mlifile, Env.empty, + Interface_not_compiled mlifile)) end; let dclsig = Env.read_signature modulename cmifile in Cmt_format.save_cmt (prefix ^ ".cmt") modulename @@ -1446,3 +1454,6 @@ let report_error ppf = function "The type %a in this module cannot be exported.@ " longident lid; fprintf ppf "Its type contains local dependencies:@ %a" type_expr ty + +let report_error env ppf err = + Printtyp.wrap_printing_env env (fun () -> report_error ppf err) diff --git a/typing/typemod.mli b/typing/typemod.mli index c90a12e457..d34bde86ac 100644 --- a/typing/typemod.mli +++ b/typing/typemod.mli @@ -61,6 +61,6 @@ type error = | Incomplete_packed_module of type_expr | Scoping_pack of Longident.t * type_expr -exception Error of Location.t * error +exception Error of Location.t * Env.t * error -val report_error: formatter -> error -> unit +val report_error: Env.t -> formatter -> error -> unit diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 98060dab5f..e87b1e410e 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -25,7 +25,7 @@ exception Already_bound type error = Unbound_type_variable of string - | Unbound_type_constructor of Env.t * Longident.t + | Unbound_type_constructor of Longident.t | Unbound_type_constructor_2 of Path.t | Type_arity_mismatch of Longident.t * int * int | Bound_type_variable of string @@ -42,16 +42,16 @@ type error = | Cannot_quantify of string * type_expr | Multiple_constraints_on_type of Longident.t | Repeated_method_label of string - | Unbound_value of Env.t * Longident.t - | Unbound_constructor of Env.t * Longident.t - | Unbound_label of Env.t * Longident.t - | Unbound_module of Env.t * Longident.t - | Unbound_class of Env.t * Longident.t - | Unbound_modtype of Env.t * Longident.t - | Unbound_cltype of Env.t * Longident.t + | Unbound_value of Longident.t + | Unbound_constructor of Longident.t + | Unbound_label of Longident.t + | Unbound_module of Longident.t + | Unbound_class of Longident.t + | Unbound_modtype of Longident.t + | Unbound_cltype of Longident.t | Ill_typed_functor_application of Longident.t -exception Error of Location.t * error +exception Error of Location.t * Env.t * error type variable_context = int * (string, type_expr) Tbl.t @@ -67,7 +67,7 @@ let rec narrow_unbound_lid_error : 'a. _ -> _ -> _ -> _ -> 'a = try ignore (Env.lookup_module mlid env) with Not_found -> narrow_unbound_lid_error env loc mlid - (fun env lid -> Unbound_module (env, lid)) + (fun lid -> Unbound_module lid) in begin match lid with | Longident.Lident _ -> () @@ -75,9 +75,9 @@ let rec narrow_unbound_lid_error : 'a. _ -> _ -> _ -> _ -> 'a = | Longident.Lapply (flid, mlid) -> check_module flid; check_module mlid; - raise (Error (loc, Ill_typed_functor_application lid)) + raise (Error (loc, env, Ill_typed_functor_application lid)) end; - raise (Error (loc, make_error env lid)) + raise (Error (loc, env, make_error lid)) let find_component lookup make_error env loc lid = try @@ -89,43 +89,34 @@ let find_component lookup make_error env loc lid = narrow_unbound_lid_error env loc lid make_error let find_type = - find_component Env.lookup_type - (fun env lid -> Unbound_type_constructor (env, lid)) + find_component Env.lookup_type (fun lid -> Unbound_type_constructor lid) let find_constructor = - find_component Env.lookup_constructor - (fun env lid -> Unbound_constructor (env, lid)) + find_component Env.lookup_constructor (fun lid -> Unbound_constructor lid) let find_all_constructors = find_component Env.lookup_all_constructors - (fun env lid -> Unbound_constructor (env, lid)) + (fun lid -> Unbound_constructor lid) let find_label = - find_component Env.lookup_label - (fun env lid -> Unbound_label (env, lid)) + find_component Env.lookup_label (fun lid -> Unbound_label lid) let find_all_labels = - find_component Env.lookup_all_labels - (fun env lid -> Unbound_label (env, lid)) + find_component Env.lookup_all_labels (fun lid -> Unbound_label lid) let find_class = - find_component Env.lookup_class - (fun env lid -> Unbound_class (env, lid)) + find_component Env.lookup_class (fun lid -> Unbound_class lid) let find_value = - find_component Env.lookup_value - (fun env lid -> Unbound_value (env, lid)) + find_component Env.lookup_value (fun lid -> Unbound_value lid) let find_module = - find_component Env.lookup_module - (fun env lid -> Unbound_module (env, lid)) + find_component Env.lookup_module (fun lid -> Unbound_module lid) let find_modtype = - find_component Env.lookup_modtype - (fun env lid -> Unbound_modtype (env, lid)) + find_component Env.lookup_modtype (fun lid -> Unbound_modtype lid) let find_class_type = - find_component Env.lookup_cltype - (fun env lid -> Unbound_cltype (env, lid)) + find_component Env.lookup_cltype (fun lid -> Unbound_cltype lid) let unbound_constructor_error env lid = narrow_unbound_lid_error env lid.loc lid.txt - (fun env lid -> Unbound_constructor (env, lid)) + (fun lid -> Unbound_constructor lid) let unbound_label_error env lid = narrow_unbound_lid_error env lid.loc lid.txt - (fun env lid -> Unbound_label (env, lid)) + (fun lid -> Unbound_label lid) (* Support for first-class modules. *) @@ -137,7 +128,7 @@ let create_package_mty fake loc env (p, l) = List.sort (fun (s1, t1) (s2, t2) -> if s1.txt = s2.txt then - raise (Error (loc, Multiple_constraints_on_type s1.txt)); + raise (Error (loc, env, Multiple_constraints_on_type s1.txt)); compare s1 s2) l in @@ -190,7 +181,7 @@ let newvar ?name () = let enter_type_variable strict loc name = try if name <> "" && name.[0] = '_' then - raise (Error (loc, Invalid_variable_name ("'" ^ name))); + raise (Error (loc, Env.empty, Invalid_variable_name ("'" ^ name))); let v = Tbl.find name !type_variables in if strict then raise Already_bound; v @@ -203,7 +194,7 @@ let type_variable loc name = try Tbl.find name !type_variables with Not_found -> - raise(Error(loc, Unbound_type_variable ("'" ^ name))) + raise(Error(loc, Env.empty, Unbound_type_variable ("'" ^ name))) let wrap_method ty = match (Ctype.repr ty).desc with @@ -229,14 +220,14 @@ let rec transl_type env policy styp = let ty = if policy = Univars then new_pre_univar () else if policy = Fixed then - raise (Error (styp.ptyp_loc, Unbound_type_variable "_")) + raise (Error (styp.ptyp_loc, env, Unbound_type_variable "_")) else newvar () in ctyp Ttyp_any ty env loc | Ptyp_var name -> let ty = if name <> "" && name.[0] = '_' then - raise (Error (styp.ptyp_loc, Invalid_variable_name ("'" ^ name))); + raise (Error (styp.ptyp_loc, env, Invalid_variable_name ("'" ^ name))); begin try instance env (List.assoc name !univars) with Not_found -> try @@ -262,8 +253,9 @@ let rec transl_type env policy styp = | Ptyp_constr(lid, stl) -> let (path, decl) = find_type env styp.ptyp_loc lid.txt in if List.length stl <> decl.type_arity then - raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid.txt, decl.type_arity, - List.length stl))); + raise(Error(styp.ptyp_loc, env, + Type_arity_mismatch(lid.txt, decl.type_arity, + List.length stl))); let args = List.map (transl_type env policy) stl in let params = instance_list decl.type_params in let unify_param = @@ -275,14 +267,14 @@ let rec transl_type env policy styp = List.iter2 (fun (sty, cty) ty' -> try unify_param env ty' cty.ctyp_type with Unify trace -> - raise (Error(sty.ptyp_loc, Type_mismatch (swap_list trace)))) + raise (Error(sty.ptyp_loc, env, Type_mismatch (swap_list trace)))) (List.combine stl args) params; let constr = newconstr path (List.map (fun ctyp -> ctyp.ctyp_type) args) in begin try Ctype.enforce_constraints env constr with Unify trace -> - raise (Error(styp.ptyp_loc, Type_mismatch trace)) + raise (Error(styp.ptyp_loc, env, Type_mismatch trace)) end; ctyp (Ttyp_constr (path, lid, args)) constr env loc | Ptyp_object fields -> @@ -326,30 +318,31 @@ let rec transl_type env policy styp = let (path, decl) = Env.lookup_type lid2 env in (path, decl, false) with Not_found -> - raise(Error(styp.ptyp_loc, Unbound_class (env, lid.txt))) + raise(Error(styp.ptyp_loc, env, Unbound_class lid.txt)) in if List.length stl <> decl.type_arity then - raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid.txt, decl.type_arity, - List.length stl))); + raise(Error(styp.ptyp_loc, env, + Type_arity_mismatch(lid.txt, decl.type_arity, + List.length stl))); let args = List.map (transl_type env policy) stl in let params = instance_list decl.type_params in List.iter2 (fun (sty, cty) ty' -> try unify_var env ty' cty.ctyp_type with Unify trace -> - raise (Error(sty.ptyp_loc, Type_mismatch (swap_list trace)))) + raise (Error(sty.ptyp_loc, env, Type_mismatch (swap_list trace)))) (List.combine stl args) params; let ty_args = List.map (fun ctyp -> ctyp.ctyp_type) args in let ty = try Ctype.expand_head env (newconstr path ty_args) with Unify trace -> - raise (Error(styp.ptyp_loc, Type_mismatch trace)) + raise (Error(styp.ptyp_loc, env, Type_mismatch trace)) in let ty = match ty.desc with Tvariant row -> let row = Btype.row_repr row in List.iter (fun l -> if not (List.mem_assoc l row.row_fields) then - raise(Error(styp.ptyp_loc, Present_has_no_type l))) + raise(Error(styp.ptyp_loc, env, Present_has_no_type l))) present; let fields = List.map @@ -392,7 +385,7 @@ let rec transl_type env policy styp = let ty = transl_type env policy st in begin try unify_var env t ty.ctyp_type with Unify trace -> let trace = swap_list trace in - raise(Error(styp.ptyp_loc, Alias_type_mismatch trace)) + raise(Error(styp.ptyp_loc, env, Alias_type_mismatch trace)) end; ty with Not_found -> @@ -402,7 +395,7 @@ let rec transl_type env policy styp = let ty = transl_type env policy st in begin try unify_var env t ty.ctyp_type with Unify trace -> let trace = swap_list trace in - raise(Error(styp.ptyp_loc, Alias_type_mismatch trace)) + raise(Error(styp.ptyp_loc, env, Alias_type_mismatch trace)) end; if !Clflags.principal then begin end_def (); @@ -430,11 +423,12 @@ let rec transl_type env policy styp = try let (l',f') = Hashtbl.find hfields h in (* Check for tag conflicts *) - if l <> l' then raise(Error(styp.ptyp_loc, Variant_tags(l, l'))); + if l <> l' then raise(Error(styp.ptyp_loc, env, Variant_tags(l, l'))); let ty = mkfield l f and ty' = mkfield l f' in if equal env false [ty] [ty'] then () else try unify env ty ty' - with Unify trace -> raise(Error(loc, Constructor_mismatch (ty,ty'))) + with Unify trace -> + raise(Error(loc, env, Constructor_mismatch (ty,ty'))) with Not_found -> Hashtbl.add hfields h (l,f) in @@ -448,7 +442,7 @@ let rec transl_type env policy styp = Reither(c, ty_tl, false, ref None) | _ -> if List.length stl > 1 || c && stl <> [] then - raise(Error(styp.ptyp_loc, Present_has_conjunction l)); + raise(Error(styp.ptyp_loc, env, Present_has_conjunction l)); match tl with [] -> Rpresent None | st :: _ -> Rpresent (Some st.ctyp_type) @@ -476,9 +470,9 @@ let rec transl_type env policy styp = let row = Btype.row_repr row in row.row_fields | {desc=Tvar _}, Some(p, _) -> - raise(Error(sty.ptyp_loc, Unbound_type_constructor_2 p)) + raise(Error(sty.ptyp_loc, env, Unbound_type_constructor_2 p)) | _ -> - raise(Error(sty.ptyp_loc, Not_a_variant ty)) + raise(Error(sty.ptyp_loc, env, Not_a_variant ty)) in List.iter (fun (l, f) -> @@ -504,7 +498,7 @@ let rec transl_type env policy styp = | Some present -> List.iter (fun l -> if not (List.mem_assoc l fields) then - raise(Error(styp.ptyp_loc, Present_has_no_type l))) + raise(Error(styp.ptyp_loc, env, Present_has_no_type l))) present end; let row = @@ -539,7 +533,7 @@ let rec transl_type env policy styp = v.desc <- Tunivar name; v :: tyl | _ -> - raise (Error (styp.ptyp_loc, Cannot_quantify (name, v))) + raise (Error (styp.ptyp_loc, env, Cannot_quantify (name, v))) end else tyl) [] new_univars in @@ -573,7 +567,7 @@ and transl_fields env policy seen = | {field_desc = Tcfield_var}::_ -> if policy = Univars then new_pre_univar () else newvar () | {field_desc = Tcfield(s, ty1); field_loc = loc}::l -> - if List.mem s seen then raise (Error (loc, Repeated_method_label s)); + if List.mem s seen then raise (Error (loc, env, Repeated_method_label s)); let ty2 = transl_fields env policy (s::seen) l in newty (Tfield (s, Fpresent, ty1.ctyp_type, ty2)) @@ -615,7 +609,7 @@ let globalize_used_variables env fixed = r := (loc, v, Tbl.find name !type_variables) :: !r with Not_found -> if fixed && Btype.is_Tvar (repr ty) then - raise(Error(loc, Unbound_type_variable ("'"^name))); + raise(Error(loc, env, Unbound_type_variable ("'"^name))); let v2 = new_global_var () in r := (loc, v, v2) :: !r; type_variables := Tbl.add name v2 !type_variables) @@ -625,7 +619,7 @@ let globalize_used_variables env fixed = List.iter (function (loc, t1, t2) -> try unify env t1 t2 with Unify trace -> - raise (Error(loc, Type_mismatch trace))) + raise (Error(loc, env, Type_mismatch trace))) !r let transl_simple_type env fixed styp = @@ -733,10 +727,10 @@ let spellcheck ppf fold = type cd = string list * int -let report_error ppf = function +let report_error env ppf = function | Unbound_type_variable name -> fprintf ppf "Unbound type parameter %s@." name - | Unbound_type_constructor (env, lid) -> + | Unbound_type_constructor lid -> fprintf ppf "Unbound type constructor %a" longident lid; spellcheck ppf Env.fold_types env lid; | Unbound_type_constructor_2 p -> @@ -756,17 +750,15 @@ let report_error ppf = function anywhere so it's unclear how it should be handled *) fprintf ppf "Unbound row variable in #%a" longident lid | Type_mismatch trace -> - Printtyp.unification_error true trace + Printtyp.report_unification_error ppf Env.empty trace (function ppf -> fprintf ppf "This type") - ppf (function ppf -> fprintf ppf "should be an instance of type") | Alias_type_mismatch trace -> - Printtyp.unification_error true trace + Printtyp.report_unification_error ppf Env.empty trace (function ppf -> fprintf ppf "This alias is bound to type") - ppf (function ppf -> fprintf ppf "but is used as an instance of type") | Present_has_conjunction l -> @@ -774,12 +766,13 @@ let report_error ppf = function | Present_has_no_type l -> fprintf ppf "The present constructor %s has no type" l | Constructor_mismatch (ty, ty') -> - Printtyp.reset_and_mark_loops_list [ty; ty']; - fprintf ppf "@[<hov>%s %a@ %s@ %a@]" - "This variant type contains a constructor" - Printtyp.type_expr ty - "which should be" - Printtyp.type_expr ty' + wrap_printing_env env (fun () -> + Printtyp.reset_and_mark_loops_list [ty; ty']; + fprintf ppf "@[<hov>%s %a@ %s@ %a@]" + "This variant type contains a constructor" + Printtyp.type_expr ty + "which should be" + Printtyp.type_expr ty') | Not_a_variant ty -> Printtyp.reset_and_mark_loops ty; fprintf ppf "@[The type %a@ is not a polymorphic variant type@]" @@ -802,26 +795,26 @@ let report_error ppf = function | Repeated_method_label s -> fprintf ppf "@[This is the second method `%s' of this object type.@ %s@]" s "Multiple occurences are not allowed." - | Unbound_value (env, lid) -> + | Unbound_value lid -> fprintf ppf "Unbound value %a" longident lid; spellcheck ppf Env.fold_values env lid; - | Unbound_module (env, lid) -> + | Unbound_module lid -> fprintf ppf "Unbound module %a" longident lid; spellcheck ppf Env.fold_modules env lid; - | Unbound_constructor (env, lid) -> + | Unbound_constructor lid -> fprintf ppf "Unbound constructor %a" longident lid; spellcheck_simple ppf Env.fold_constructors (fun d -> d.cstr_name) env lid; - | Unbound_label (env, lid) -> + | Unbound_label lid -> fprintf ppf "Unbound record field %a" longident lid; spellcheck_simple ppf Env.fold_labels (fun d -> d.lbl_name) env lid; - | Unbound_class (env, lid) -> + | Unbound_class lid -> fprintf ppf "Unbound class %a" longident lid; spellcheck ppf Env.fold_classs env lid; - | Unbound_modtype (env, lid) -> + | Unbound_modtype lid -> fprintf ppf "Unbound module type %a" longident lid; spellcheck ppf Env.fold_modtypes env lid; - | Unbound_cltype (env, lid) -> + | Unbound_cltype lid -> fprintf ppf "Unbound class type %a" longident lid; spellcheck ppf Env.fold_cltypes env lid; | Ill_typed_functor_application lid -> diff --git a/typing/typetexp.mli b/typing/typetexp.mli index fadc820704..d47bf7a644 100644 --- a/typing/typetexp.mli +++ b/typing/typetexp.mli @@ -12,7 +12,7 @@ (* Typechecking of type expressions for the core language *) -open Format;; +open Types val transl_simple_type: Env.t -> bool -> Parsetree.core_type -> Typedtree.core_type @@ -25,8 +25,8 @@ val transl_simple_type_delayed: val transl_type_scheme: Env.t -> Parsetree.core_type -> Typedtree.core_type val reset_type_variables: unit -> unit -val enter_type_variable: bool -> Location.t -> string -> Types.type_expr -val type_variable: Location.t -> string -> Types.type_expr +val enter_type_variable: bool -> Location.t -> string -> type_expr +val type_variable: Location.t -> string -> type_expr type variable_context val narrow: unit -> variable_context @@ -36,35 +36,35 @@ exception Already_bound type error = Unbound_type_variable of string - | Unbound_type_constructor of Env.t * Longident.t + | Unbound_type_constructor of Longident.t | Unbound_type_constructor_2 of Path.t | Type_arity_mismatch of Longident.t * int * int | Bound_type_variable of string | Recursive_type | Unbound_row_variable of Longident.t - | Type_mismatch of (Types.type_expr * Types.type_expr) list - | Alias_type_mismatch of (Types.type_expr * Types.type_expr) list + | Type_mismatch of (type_expr * type_expr) list + | Alias_type_mismatch of (type_expr * type_expr) list | Present_has_conjunction of string | Present_has_no_type of string - | Constructor_mismatch of Types.type_expr * Types.type_expr - | Not_a_variant of Types.type_expr + | Constructor_mismatch of type_expr * type_expr + | Not_a_variant of type_expr | Variant_tags of string * string | Invalid_variable_name of string - | Cannot_quantify of string * Types.type_expr + | Cannot_quantify of string * type_expr | Multiple_constraints_on_type of Longident.t | Repeated_method_label of string - | Unbound_value of Env.t * Longident.t - | Unbound_constructor of Env.t * Longident.t - | Unbound_label of Env.t * Longident.t - | Unbound_module of Env.t * Longident.t - | Unbound_class of Env.t * Longident.t - | Unbound_modtype of Env.t * Longident.t - | Unbound_cltype of Env.t * Longident.t + | Unbound_value of Longident.t + | Unbound_constructor of Longident.t + | Unbound_label of Longident.t + | Unbound_module of Longident.t + | Unbound_class of Longident.t + | Unbound_modtype of Longident.t + | Unbound_cltype of Longident.t | Ill_typed_functor_application of Longident.t -exception Error of Location.t * error +exception Error of Location.t * Env.t * error -val report_error: formatter -> error -> unit +val report_error: Env.t -> Format.formatter -> error -> unit (* Support for first-class modules. *) val transl_modtype_longident: (* from Typemod *) @@ -77,27 +77,27 @@ val create_package_mty: Parsetree.module_type val find_type: - Env.t -> Location.t -> Longident.t -> Path.t * Types.type_declaration + Env.t -> Location.t -> Longident.t -> Path.t * type_declaration val find_constructor: - Env.t -> Location.t -> Longident.t -> Types.constructor_description + Env.t -> Location.t -> Longident.t -> constructor_description val find_all_constructors: Env.t -> Location.t -> Longident.t -> - (Types.constructor_description * (unit -> unit)) list + (constructor_description * (unit -> unit)) list val find_label: - Env.t -> Location.t -> Longident.t -> Types.label_description + Env.t -> Location.t -> Longident.t -> label_description val find_all_labels: Env.t -> Location.t -> Longident.t -> - (Types.label_description * (unit -> unit)) list + (label_description * (unit -> unit)) list val find_value: - Env.t -> Location.t -> Longident.t -> Path.t * Types.value_description + Env.t -> Location.t -> Longident.t -> Path.t * value_description val find_class: - Env.t -> Location.t -> Longident.t -> Path.t * Types.class_declaration + Env.t -> Location.t -> Longident.t -> Path.t * class_declaration val find_module: - Env.t -> Location.t -> Longident.t -> Path.t * Types.module_type + Env.t -> Location.t -> Longident.t -> Path.t * module_type val find_modtype: - Env.t -> Location.t -> Longident.t -> Path.t * Types.modtype_declaration + Env.t -> Location.t -> Longident.t -> Path.t * modtype_declaration val find_class_type: - Env.t -> Location.t -> Longident.t -> Path.t * Types.class_type_declaration + Env.t -> Location.t -> Longident.t -> Path.t * class_type_declaration val unbound_constructor_error: Env.t -> Longident.t Location.loc -> 'a val unbound_label_error: Env.t -> Longident.t Location.loc -> 'a diff --git a/utils/clflags.ml b/utils/clflags.ml index 810d3f7662..e085577c13 100644 --- a/utils/clflags.ml +++ b/utils/clflags.ml @@ -44,6 +44,7 @@ and init_file = ref (None : string option) (* -init *) and use_prims = ref "" (* -use-prims ... *) and use_runtime = ref "" (* -use-runtime ... *) and principal = ref false (* -principal *) +and real_paths = ref true (* -short-paths *) and recursive_types = ref false (* -rectypes *) and strict_sequence = ref false (* -strict-sequence *) and applicative_functors = ref true (* -no-app-funct *) diff --git a/utils/clflags.mli b/utils/clflags.mli index 5dce10754a..69e367f89e 100644 --- a/utils/clflags.mli +++ b/utils/clflags.mli @@ -41,6 +41,7 @@ val init_file : string option ref val use_prims : string ref val use_runtime : string ref val principal : bool ref +val real_paths : bool ref val recursive_types : bool ref val strict_sequence : bool ref val applicative_functors : bool ref |