Merge pull request #2096 from Armael/quote_location2

In error messages, print the source fragment responsible for the error

.depend

@@ -354,8 +354,7 @@ typing/subst.cmo : typing/types.cmi typing/path.cmi parsing/parsetree.cmi \
 typing/subst.cmx : typing/types.cmx typing/path.cmx parsing/parsetree.cmi \
     utils/misc.cmx parsing/location.cmx typing/ident.cmx utils/clflags.cmx \
     typing/btype.cmx parsing/ast_mapper.cmx typing/subst.cmi
-typing/subst.cmi : typing/types.cmi typing/path.cmi parsing/location.cmi \
-    typing/ident.cmi
+typing/subst.cmi : typing/types.cmi typing/path.cmi typing/ident.cmi
 typing/tast_mapper.cmo : typing/typedtree.cmi typing/env.cmi \
     parsing/asttypes.cmi typing/tast_mapper.cmi
 typing/tast_mapper.cmx : typing/typedtree.cmx typing/env.cmx \
@@ -717,14 +716,14 @@ bytecomp/translcore.cmi : typing/typedtree.cmi typing/path.cmi \
     parsing/asttypes.cmi
 bytecomp/translmod.cmo : typing/types.cmi typing/typedtree.cmi \
     bytecomp/translprim.cmi bytecomp/translobj.cmi bytecomp/translcore.cmi \
-    bytecomp/translclass.cmi bytecomp/translattribute.cmi typing/printtyp.cmi \
+    bytecomp/translclass.cmi bytecomp/translattribute.cmi \
     typing/primitive.cmi typing/predef.cmi typing/path.cmi typing/mtype.cmi \
     utils/misc.cmi parsing/longident.cmi parsing/location.cmi \
     bytecomp/lambda.cmi typing/ident.cmi typing/env.cmi typing/ctype.cmi \
     utils/clflags.cmi parsing/asttypes.cmi bytecomp/translmod.cmi
 bytecomp/translmod.cmx : typing/types.cmx typing/typedtree.cmx \
     bytecomp/translprim.cmx bytecomp/translobj.cmx bytecomp/translcore.cmx \
-    bytecomp/translclass.cmx bytecomp/translattribute.cmx typing/printtyp.cmx \
+    bytecomp/translclass.cmx bytecomp/translattribute.cmx \
     typing/primitive.cmx typing/predef.cmx typing/path.cmx typing/mtype.cmx \
     utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
     bytecomp/lambda.cmx typing/ident.cmx typing/env.cmx typing/ctype.cmx \
@@ -917,28 +916,30 @@ asmcomp/closure_offsets.cmx : middle_end/base_types/variable.cmx \
     middle_end/base_types/closure_id.cmx asmcomp/closure_offsets.cmi
 asmcomp/closure_offsets.cmi : middle_end/base_types/var_within_closure.cmi \
     middle_end/flambda.cmi middle_end/base_types/closure_id.cmi
-asmcomp/cmm.cmo : bytecomp/lambda.cmi middle_end/debuginfo.cmi \
-    asmcomp/clambda.cmi asmcomp/backend_var.cmi parsing/asttypes.cmi \
+asmcomp/cmm.cmo : utils/targetint.cmi bytecomp/lambda.cmi \
+    middle_end/debuginfo.cmi asmcomp/backend_var.cmi parsing/asttypes.cmi \
     asmcomp/arch.cmo asmcomp/cmm.cmi
-asmcomp/cmm.cmx : bytecomp/lambda.cmx middle_end/debuginfo.cmx \
-    asmcomp/clambda.cmx asmcomp/backend_var.cmx parsing/asttypes.cmi \
+asmcomp/cmm.cmx : utils/targetint.cmx bytecomp/lambda.cmx \
+    middle_end/debuginfo.cmx asmcomp/backend_var.cmx parsing/asttypes.cmi \
     asmcomp/arch.cmx asmcomp/cmm.cmi
-asmcomp/cmm.cmi : bytecomp/lambda.cmi middle_end/debuginfo.cmi \
-    asmcomp/clambda.cmi asmcomp/backend_var.cmi parsing/asttypes.cmi
-asmcomp/cmmgen.cmo : asmcomp/un_anf.cmi typing/types.cmi bytecomp/switch.cmi \
-    asmcomp/strmatch.cmi asmcomp/proc.cmi bytecomp/printlambda.cmi \
-    typing/primitive.cmi utils/numbers.cmi utils/misc.cmi bytecomp/lambda.cmi \
-    middle_end/debuginfo.cmi utils/config.cmi asmcomp/compilenv.cmi \
-    asmcomp/cmx_format.cmi asmcomp/cmm.cmi utils/clflags.cmi \
-    asmcomp/clambda.cmi asmcomp/backend_var.cmi parsing/asttypes.cmi \
-    asmcomp/arch.cmo asmcomp/afl_instrument.cmi asmcomp/cmmgen.cmi
-asmcomp/cmmgen.cmx : asmcomp/un_anf.cmx typing/types.cmx bytecomp/switch.cmx \
-    asmcomp/strmatch.cmx asmcomp/proc.cmx bytecomp/printlambda.cmx \
-    typing/primitive.cmx utils/numbers.cmx utils/misc.cmx bytecomp/lambda.cmx \
-    middle_end/debuginfo.cmx utils/config.cmx asmcomp/compilenv.cmx \
-    asmcomp/cmx_format.cmi asmcomp/cmm.cmx utils/clflags.cmx \
-    asmcomp/clambda.cmx asmcomp/backend_var.cmx parsing/asttypes.cmi \
-    asmcomp/arch.cmx asmcomp/afl_instrument.cmx asmcomp/cmmgen.cmi
+asmcomp/cmm.cmi : utils/targetint.cmi bytecomp/lambda.cmi \
+    middle_end/debuginfo.cmi asmcomp/backend_var.cmi parsing/asttypes.cmi
+asmcomp/cmmgen.cmo : asmcomp/un_anf.cmi typing/types.cmi utils/targetint.cmi \
+    bytecomp/switch.cmi asmcomp/strmatch.cmi asmcomp/proc.cmi \
+    bytecomp/printlambda.cmi typing/primitive.cmi utils/numbers.cmi \
+    utils/misc.cmi bytecomp/lambda.cmi middle_end/debuginfo.cmi \
+    utils/config.cmi asmcomp/compilenv.cmi asmcomp/cmx_format.cmi \
+    asmcomp/cmm.cmi utils/clflags.cmi asmcomp/clambda.cmi \
+    asmcomp/backend_var.cmi parsing/asttypes.cmi asmcomp/arch.cmo \
+    asmcomp/afl_instrument.cmi asmcomp/cmmgen.cmi
+asmcomp/cmmgen.cmx : asmcomp/un_anf.cmx typing/types.cmx utils/targetint.cmx \
+    bytecomp/switch.cmx asmcomp/strmatch.cmx asmcomp/proc.cmx \
+    bytecomp/printlambda.cmx typing/primitive.cmx utils/numbers.cmx \
+    utils/misc.cmx bytecomp/lambda.cmx middle_end/debuginfo.cmx \
+    utils/config.cmx asmcomp/compilenv.cmx asmcomp/cmx_format.cmi \
+    asmcomp/cmm.cmx utils/clflags.cmx asmcomp/clambda.cmx \
+    asmcomp/backend_var.cmx parsing/asttypes.cmi asmcomp/arch.cmx \
+    asmcomp/afl_instrument.cmx asmcomp/cmmgen.cmi
 asmcomp/cmmgen.cmi : asmcomp/cmx_format.cmi asmcomp/cmm.cmi \
     asmcomp/clambda.cmi
 asmcomp/cmx_format.cmi : asmcomp/export_info.cmi asmcomp/clambda.cmi
@@ -1140,10 +1141,10 @@ asmcomp/printclambda.cmx : bytecomp/printlambda.cmx bytecomp/lambda.cmx \
     typing/ident.cmx asmcomp/clambda.cmx asmcomp/backend_var.cmx \
     parsing/asttypes.cmi asmcomp/printclambda.cmi
 asmcomp/printclambda.cmi : asmcomp/clambda.cmi
-asmcomp/printcmm.cmo : asmcomp/printclambda.cmi bytecomp/lambda.cmi \
+asmcomp/printcmm.cmo : utils/targetint.cmi bytecomp/lambda.cmi \
     middle_end/debuginfo.cmi asmcomp/cmm.cmi asmcomp/backend_var.cmi \
     parsing/asttypes.cmi asmcomp/printcmm.cmi
-asmcomp/printcmm.cmx : asmcomp/printclambda.cmx bytecomp/lambda.cmx \
+asmcomp/printcmm.cmx : utils/targetint.cmx bytecomp/lambda.cmx \
     middle_end/debuginfo.cmx asmcomp/cmm.cmx asmcomp/backend_var.cmx \
     parsing/asttypes.cmi asmcomp/printcmm.cmi
 asmcomp/printcmm.cmi : middle_end/debuginfo.cmi asmcomp/cmm.cmi
@@ -2507,13 +2508,13 @@ toplevel/opttoploop.cmi : utils/warnings.cmi typing/types.cmi \
     typing/path.cmi parsing/parsetree.cmi typing/outcometree.cmi \
     parsing/longident.cmi parsing/location.cmi typing/env.cmi
 toplevel/opttopmain.cmo : utils/warnings.cmi asmcomp/printmach.cmi \
-    toplevel/opttoploop.cmi toplevel/opttopdirs.cmi driver/main_args.cmi \
-    parsing/location.cmi driver/compmisc.cmi driver/compenv.cmi \
-    utils/clflags.cmi toplevel/opttopmain.cmi
+    toplevel/opttoploop.cmi toplevel/opttopdirs.cmi utils/misc.cmi \
+    driver/main_args.cmi parsing/location.cmi driver/compmisc.cmi \
+    driver/compenv.cmi utils/clflags.cmi toplevel/opttopmain.cmi
 toplevel/opttopmain.cmx : utils/warnings.cmx asmcomp/printmach.cmx \
-    toplevel/opttoploop.cmx toplevel/opttopdirs.cmx driver/main_args.cmx \
-    parsing/location.cmx driver/compmisc.cmx driver/compenv.cmx \
-    utils/clflags.cmx toplevel/opttopmain.cmi
+    toplevel/opttoploop.cmx toplevel/opttopdirs.cmx utils/misc.cmx \
+    driver/main_args.cmx parsing/location.cmx driver/compmisc.cmx \
+    driver/compenv.cmx utils/clflags.cmx toplevel/opttopmain.cmi
 toplevel/opttopmain.cmi :
 toplevel/opttopstart.cmo : toplevel/opttopmain.cmi
 toplevel/opttopstart.cmx : toplevel/opttopmain.cmx
@@ -2568,13 +2569,13 @@ toplevel/toploop.cmi : utils/warnings.cmi typing/types.cmi typing/path.cmi \
     parsing/parsetree.cmi typing/outcometree.cmi parsing/longident.cmi \
     parsing/location.cmi typing/env.cmi
 toplevel/topmain.cmo : utils/warnings.cmi toplevel/toploop.cmi \
-    toplevel/topdirs.cmi utils/profile.cmi driver/main_args.cmi \
-    parsing/location.cmi driver/compmisc.cmi driver/compenv.cmi \
-    utils/clflags.cmi toplevel/topmain.cmi
+    toplevel/topdirs.cmi utils/profile.cmi utils/misc.cmi \
+    driver/main_args.cmi parsing/location.cmi driver/compmisc.cmi \
+    driver/compenv.cmi utils/clflags.cmi toplevel/topmain.cmi
 toplevel/topmain.cmx : utils/warnings.cmx toplevel/toploop.cmx \
-    toplevel/topdirs.cmx utils/profile.cmx driver/main_args.cmx \
-    parsing/location.cmx driver/compmisc.cmx driver/compenv.cmx \
-    utils/clflags.cmx toplevel/topmain.cmi
+    toplevel/topdirs.cmx utils/profile.cmx utils/misc.cmx \
+    driver/main_args.cmx parsing/location.cmx driver/compmisc.cmx \
+    driver/compenv.cmx utils/clflags.cmx toplevel/topmain.cmi
 toplevel/topmain.cmi :
 toplevel/topstart.cmo : toplevel/topmain.cmi
 toplevel/topstart.cmx : toplevel/topmain.cmx

.gitattributes

@@ -72,6 +72,7 @@ emacs/COPYING            typo.prune
 emacs/ocamltags.in       typo.non-printing
 
 /manual                  typo.prune
+/manual/manual/cmds/unified-options.etex typo.missing-header
 
 ocamldoc/**              typo.long-line=may
 ocamldoc/Changes.txt     typo.missing-header
@@ -86,7 +87,7 @@ runtime/i386.S      typo.long-line
 
 stdlib/hashbang     typo.white-at-eol typo.missing-lf
 
-testsuite/tests/**                                      typo.missing-header
+testsuite/tests/**                                      typo.missing-header typo.long-line=may
 testsuite/tests/lib-bigarray-2/bigarrf.f                typo.tab
 testsuite/tests/lib-unix/win-stat/fakeclock.c           typo.missing-header=false
 testsuite/tests/misc-unsafe/almabench.ml                typo.long-line
@@ -101,11 +102,6 @@ testsuite/tests/**/*.reference               typo.prune
 
 # Expect tests with overly long lines of expected output
 testsuite/tests/parsing/docstrings.ml        typo.very-long-line
-testsuite/tests/typing-objects/Exemples.ml   typo.long-line
-testsuite/tests/typing-modules/firstclass.ml typo.long-line
-testsuite/tests/typing-gadts/test.ml         typo.long-line
-testsuite/tests/typing-gadts/pr7160.ml       typo.long-line
-testsuite/tests/typing-modules/pr7726.ml     typo.long-line
 
 tools/magic         typo.missing-header
 

Changes

@@ -121,6 +121,9 @@ Working version
 
 ### Compiler user-interface and warnings:
 
+- PR#2096: Add source highlighting for errors & warnings in batch mode
+  (Armaël Guéneau, review by Gabriel Scherer and Jérémie Dimino)
+
 - PR#2091: Add a warning triggered by type declarations "type t = ()"
   (Armaël Guéneau, report by linse, review by Florian Angeletti and Gabriel
   Scherer)

driver/compenv.ml

@@ -342,14 +342,21 @@ let read_one_param ppf position name v =
 
   (* color output *)
   | "color" ->
-      begin match parse_color_setting v with
+      begin match color_reader.parse v with
       | None ->
         Printf.ksprintf (print_error ppf)
-          "bad value %s for \"color\", \
-           (expected \"auto\", \"always\" or \"never\")" v
+          "bad value %s for \"color\", (%s)" v color_reader.usage
       | Some setting -> color := Some setting
       end
 
+  | "error-style" ->
+      begin match error_style_reader.parse v with
+      | None ->
+          Printf.ksprintf (print_error ppf)
+            "bad value %s for \"error-style\", (%s)" v error_style_reader.usage
+      | Some setting -> error_style := Some setting
+      end
+
   | "intf-suffix" -> Config.interface_suffix := v
 
   | "I" -> begin

driver/compmisc.ml

@@ -57,20 +57,23 @@ let initial_env () =
     ~initially_opened_module
     ~open_implicit_modules:(List.rev !Clflags.open_modules)
 
-let read_color_env () =
+let set_from_env flag Clflags.{ parse; usage; env_var } =
   try
-    match Clflags.parse_color_setting (Sys.getenv "OCAML_COLOR") with
+    match parse (Sys.getenv env_var) with
     | None ->
         Location.prerr_warning Location.none
-          (Warnings.Bad_env_variable
-             ("OCAML_COLOR",
-              "expected \"auto\", \"always\" or \"never\""));
-    | Some x -> match !Clflags.color with
-      | None -> Clflags.color := Some x
+          (Warnings.Bad_env_variable (env_var, usage))
+    | Some x -> match !flag with
+      | None -> flag := Some x
       | Some _ -> ()
   with
     Not_found -> ()
 
+let read_clflags_from_env () =
+  set_from_env Clflags.color Clflags.color_reader;
+  set_from_env Clflags.error_style Clflags.error_style_reader;
+  ()
+
 let with_ppf_dump ~fileprefix f =
   let ppf_dump, finally =
     if not !Clflags.dump_into_file

driver/compmisc.mli

@@ -16,6 +16,8 @@
 val init_path : ?dir:string -> bool -> unit
 val initial_env : unit -> Env.t
 
-val read_color_env : unit -> unit
+(* Support for flags that can also be set from an environment variable *)
+val set_from_env : 'a option ref -> 'a Clflags.env_reader -> unit
+val read_clflags_from_env : unit -> unit
 
 val with_ppf_dump : fileprefix:string -> (Format.formatter -> unit) -> unit

driver/main.ml

@@ -114,11 +114,8 @@ module Options = Main_args.Make_bytecomp_options (struct
   let _w = (Warnings.parse_options false)
   let _warn_error = (Warnings.parse_options true)
   let _warn_help = Warnings.help_warnings
-  let _color option =
-    begin match parse_color_setting option with
-          | None -> ()
-          | Some setting -> color := Some setting
-    end
+  let _color = Misc.set_or_ignore color_reader.parse color
+  let _error_style = Misc.set_or_ignore error_style_reader.parse error_style
   let _where = print_standard_library
   let _verbose = set verbose
   let _nopervasives = set nopervasives
@@ -156,7 +153,7 @@ let main () =
   try
     readenv ppf Before_args;
     Clflags.parse_arguments anonymous usage;
-    Compmisc.read_color_env ();
+    Compmisc.read_clflags_from_env ();
     if !Clflags.use_vmthreads then
       Location.deprecated Location.none vmthread_deprecated_message;
     begin try

driver/main_args.ml

@@ -597,7 +597,22 @@ let mk_color f =
   \      never   disable colors\n\
   \    The default setting is 'auto', and the current heuristic\n\
   \    checks that the TERM environment variable exists and is\n\
-  \    not empty or \"dumb\", and that isatty(stderr) holds."
+  \    not empty or \"dumb\", and that isatty(stderr) holds.\n\
+  \  If the option is not specified, these setting can alternatively\n\
+  \  be set through the OCAML_COLOR environment variable."
+;;
+
+let mk_error_style f =
+  "-error-style", Arg.Symbol (["contextual"; "short"], f),
+  Printf.sprintf
+    "  Control the way error messages and warnings are printed\n\
+    \    The following settings are supported:\n\
+    \      short       only print the error and its location\n\
+    \      contextual  like \"short\", but also display the source code\n\
+    \                  snippet corresponding to the location of the error\n\
+    \    The default setting is 'contextual'.\n\
+    \  If the option is not specified, these setting can alternatively\n\
+    \  be set through the OCAML_ERROR_STYLE environment variable."
 ;;
 
 let mk_where f =
@@ -901,6 +916,7 @@ module type Compiler_options = sig
   val _verbose : unit -> unit
   val _where : unit -> unit
   val _color : string -> unit
+  val _error_style : string -> unit
 
   val _match_context_rows : int -> unit
   val _dtimings : unit -> unit
@@ -922,6 +938,8 @@ module type Toplevel_options = sig
   val _stdin : unit -> unit
   val _args : string -> string array
   val _args0 : string -> string array
+  val _color : string -> unit
+  val _error_style : string -> unit
 end
 ;;
 
@@ -1056,6 +1074,7 @@ struct
     mk_cclib F._cclib;
     mk_ccopt F._ccopt;
     mk_color F._color;
+    mk_error_style F._error_style;
     mk_compat_32 F._compat_32;
     mk_config F._config;
     mk_config_var F._config_var;
@@ -1193,6 +1212,8 @@ struct
     mk_warn_error F._warn_error;
     mk_warn_help F._warn_help;
     mk__ F.anonymous;
+    mk_color F._color;
+    mk_error_style F._error_style;
 
     mk_dno_unique_ids F._dno_unique_ids;
     mk_dunique_ids F._dunique_ids;
@@ -1225,6 +1246,7 @@ struct
     mk_clambda_checks F._clambda_checks;
     mk_classic_inlining F._classic_inlining;
     mk_color F._color;
+    mk_error_style F._error_style;
     mk_compact F._compact;
     mk_config F._config;
     mk_config_var F._config_var;
@@ -1421,6 +1443,8 @@ module Make_opttop_options (F : Opttop_options) = struct
     mk_warn_error F._warn_error;
     mk_warn_help F._warn_help;
     mk__ F.anonymous;
+    mk_color F._color;
+    mk_error_style F._error_style;
 
     mk_dsource F._dsource;
     mk_dparsetree F._dparsetree;

driver/main_args.mli

@@ -102,6 +102,7 @@ module type Compiler_options = sig
   val _verbose : unit -> unit
   val _where : unit -> unit
   val _color : string -> unit
+  val _error_style : string -> unit
 
   val _match_context_rows : int -> unit
   val _dtimings : unit -> unit
@@ -123,6 +124,8 @@ module type Toplevel_options = sig
   val _stdin : unit -> unit
   val _args: string -> string array
   val _args0: string -> string array
+  val _color : string -> unit
+  val _error_style : string -> unit
 
 end
 ;;

driver/optmain.ml

@@ -198,13 +198,9 @@ module Options = Main_args.Make_optcomp_options (struct
   let _w s = Warnings.parse_options false s
   let _warn_error s = Warnings.parse_options true s
   let _warn_help = Warnings.help_warnings
-  let _color option =
-    begin match parse_color_setting option with
-          | None -> ()
-          | Some setting -> color := Some setting
-    end
+  let _color = Misc.set_or_ignore color_reader.parse color
+  let _error_style = Misc.set_or_ignore error_style_reader.parse error_style
   let _where () = print_standard_library ()
-
   let _nopervasives = set nopervasives
   let _match_context_rows n = match_context_rows := n
   let _dump_into_file = set dump_into_file
@@ -263,7 +259,7 @@ let main () =
        "<options> Compute dependencies \
         (use 'ocamlopt -depend -help' for details)"];
     Clflags.parse_arguments anonymous usage;
-    Compmisc.read_color_env ();
+    Compmisc.read_clflags_from_env ();
     if !gprofile && not Config.profiling then
       fatal "Profiling with \"gprof\" is not supported on this platform.";
     begin try

driver/pparse.ml

@@ -184,6 +184,7 @@ let file_aux ~tool_name inputfile (type a) parse_fun invariant_fun
         seek_in ic 0;
         let lexbuf = Lexing.from_channel ic in
         Location.init lexbuf inputfile;
+        Location.input_lexbuf := Some lexbuf;
         Profile.record_call "parser" (fun () -> parse_fun lexbuf)
       end
     with x -> close_in ic; raise x