diff --git a/src/build_interpret.ml b/src/build_interpret.ml index 5fb251a0..bab0e03d 100644 --- a/src/build_interpret.ml +++ b/src/build_interpret.ml @@ -83,11 +83,11 @@ let static_deps t ~all_targets ~file_tree = if Path.Set.is_empty result then begin match inspect_path file_tree dir with | None -> - Dloc.warn loc "Directory %s doesn't exist." + Errors.warn loc "Directory %s doesn't exist." (Path.to_string_maybe_quoted (Path.drop_optional_build_context dir)) | Some Reg -> - Dloc.warn loc "%s is not a directory." + Errors.warn loc "%s is not a directory." (Path.to_string_maybe_quoted (Path.drop_optional_build_context dir)) | Some Dir -> diff --git a/src/build_system.ml b/src/build_system.ml index f2569fba..91347ef9 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -565,7 +565,7 @@ let add_spec t fn spec ~copy_source = | Some (File_spec.T { rule; _ }) -> match copy_source, rule.mode with | true, (Standard | Not_a_rule_stanza) -> - Dloc.warn (Internal_rule.loc rule ~dir:(Path.parent_exn fn) + Errors.warn (Internal_rule.loc rule ~dir:(Path.parent_exn fn) ~file_tree:t.file_tree) "File %s is both generated by a rule and present in the source tree.\n\ As a result, the rule is currently ignored, however this will become an error \ diff --git a/src/dir_contents.ml b/src/dir_contents.ml index 7d8f8aa8..25084014 100644 --- a/src/dir_contents.ml +++ b/src/dir_contents.ml @@ -101,7 +101,7 @@ end = struct if missing_intf_only <> [] then begin match Ordered_set_lang.loc buildable.modules_without_implementation with | None -> - Dloc.warn buildable.loc + Errors.warn buildable.loc "Some modules don't have an implementation.\ \nYou need to add the following field to this stanza:\ \n\ @@ -122,7 +122,7 @@ end = struct |> List.map ~f:(sprintf "- %s") |> String.concat ~sep:"\n" in - Dloc.warn loc + Errors.warn loc "The following modules must be listed here as they don't \ have an implementation:\n\ %s\n\ @@ -155,7 +155,7 @@ end = struct ) in Module.Name.Map.iteri fake_modules ~f:(fun m loc -> - Dloc.warn loc "Module %a is excluded but it doesn't exist." + Errors.warn loc "Module %a is excluded but it doesn't exist." Module.Name.pp m ); check_invalid_module_listing ~buildable:conf ~intf_only ~modules @@ -442,7 +442,7 @@ let build_modules_map (d : Super_context.Dir_with_jbuild.t) ~modules = List.sort ~compare (b.Buildable.loc :: List.map rest ~f:(fun b -> b.Buildable.loc)) in - Dloc.warn (Loc.in_file b.loc.start.pos_fname) + Errors.warn (Loc.in_file b.loc.start.pos_fname) "Module %a is used in several stanzas:@\n\ @[%a@]@\n\ @[%a@]@\n\ diff --git a/src/dloc.ml b/src/dloc.ml deleted file mode 100644 index 4f2fcb80..00000000 --- a/src/dloc.ml +++ /dev/null @@ -1,65 +0,0 @@ -open! Stdune -open Import - -include Loc - -let in_file = Loc.in_file - -let file_line path n = - Io.with_file_in ~binary:false path - ~f:(fun ic -> - for _ = 1 to n - 1 do - ignore (input_line ic) - done; - input_line ic - ) - -let file_lines path ~start ~stop = - Io.with_file_in ~binary:true path - ~f:(fun ic -> - let rec aux acc lnum = - if lnum > stop then - List.rev acc - else if lnum < start then - (ignore (input_line ic); - aux acc (lnum + 1)) - else - let line = input_line ic in - aux ((string_of_int lnum, line) :: acc) (lnum + 1) - in - aux [] 1 - ) - -let print ppf loc = - let { Loc.start; stop } = loc in - let start_c = start.pos_cnum - start.pos_bol in - let stop_c = stop.pos_cnum - start.pos_bol in - let num_lines = stop.pos_lnum - start.pos_lnum in - let pp_file_excerpt pp () = - let whole_file = start_c = 0 && stop_c = 0 in - if not whole_file then - let path = Path.of_string start.pos_fname in - if Path.exists path then - let line = file_line path start.pos_lnum in - if stop_c <= String.length line then - let len = stop_c - start_c in - Format.fprintf pp "%s\n%*s\n" line - stop_c - (String.make len '^') - else if num_lines <= 10 then - let lines = file_lines path ~start:start.pos_lnum ~stop:stop.pos_lnum in - let last_lnum = Option.map ~f:fst (List.last lines) in - let padding_width = Option.value_exn - (Option.map ~f:String.length last_lnum) in - List.iter ~f:(fun (lnum, l) -> - Format.fprintf pp "%*s: %s\n" padding_width lnum l) - lines - in - Format.fprintf ppf - "@{File \"%s\", line %d, characters %d-%d:@}@\n%a" - start.pos_fname start.pos_lnum start_c stop_c - pp_file_excerpt () - -let warn t fmt = - Errors.kerrf ~f:print_to_console - ("%a@{Warning@}: " ^^ fmt ^^ "@.") print t diff --git a/src/dloc.mli b/src/dloc.mli deleted file mode 100644 index 9e49620a..00000000 --- a/src/dloc.mli +++ /dev/null @@ -1,16 +0,0 @@ -open! Stdune - -type t = Loc.t = - { start : Lexing.position - ; stop : Lexing.position - } - -val in_file : string -> t - -val none : t - -(** Prints "File ..., line ..., characters ...:\n" *) -val print : Format.formatter -> t -> unit - -(** Prints a warning *) -val warn : t -> ('a, Format.formatter, unit) format -> 'a diff --git a/src/dune_file.ml b/src/dune_file.ml index 13d3becf..90f84950 100644 --- a/src/dune_file.ml +++ b/src/dune_file.ml @@ -80,7 +80,7 @@ end = struct match res, wrapped with | Ok s, _ -> s | Warn _, true -> Errors.fail loc "%s" wrapped_message - | Warn s, false -> Dloc.warn loc "%s" wrapped_message; s + | Warn s, false -> Errors.warn loc "%s" wrapped_message; s | Invalid, _ -> Errors.fail loc "%s" invalid_message let valid_char = function @@ -1289,7 +1289,7 @@ module Executables = struct | Some (loc, _) -> let func = match file_kind with - | Jbuild -> Dloc.warn + | Jbuild -> Errors.warn | Dune -> Errors.fail in func loc diff --git a/src/errors.ml b/src/errors.ml index 24114448..302d0a73 100644 --- a/src/errors.ml +++ b/src/errors.ml @@ -33,3 +33,66 @@ let fail_opt t fmt = match t with | None -> die fmt | Some t -> fail t fmt + +let file_line path n = + Io.with_file_in ~binary:false path + ~f:(fun ic -> + for _ = 1 to n - 1 do + ignore (input_line ic) + done; + input_line ic + ) + +let file_lines path ~start ~stop = + Io.with_file_in ~binary:true path + ~f:(fun ic -> + let rec aux acc lnum = + if lnum > stop then + List.rev acc + else if lnum < start then + (ignore (input_line ic); + aux acc (lnum + 1)) + else + let line = input_line ic in + aux ((string_of_int lnum, line) :: acc) (lnum + 1) + in + aux [] 1 + ) + +let print ppf loc = + let { Loc.start; stop } = loc in + let start_c = start.pos_cnum - start.pos_bol in + let stop_c = stop.pos_cnum - start.pos_bol in + let num_lines = stop.pos_lnum - start.pos_lnum in + let pp_file_excerpt pp () = + let whole_file = start_c = 0 && stop_c = 0 in + if not whole_file then + let path = Path.of_string start.pos_fname in + if Path.exists path then + let line = file_line path start.pos_lnum in + if stop_c <= String.length line then + let len = stop_c - start_c in + Format.fprintf pp "%s\n%*s\n" line + stop_c + (String.make len '^') + else if num_lines <= 10 then + let lines = file_lines path ~start:start.pos_lnum ~stop:stop.pos_lnum in + let last_lnum = Option.map ~f:fst (List.last lines) in + let padding_width = Option.value_exn + (Option.map ~f:String.length last_lnum) in + List.iter ~f:(fun (lnum, l) -> + Format.fprintf pp "%*s: %s\n" padding_width lnum l) + lines + in + Format.fprintf ppf + "@{File \"%s\", line %d, characters %d-%d:@}@\n%a" + start.pos_fname start.pos_lnum start_c stop_c + pp_file_excerpt () + +(* This is ugly *) +let printer = ref (Printf.eprintf "%s%!") +let print_to_console s = !printer s + +let warn t fmt = + kerrf ~f:print_to_console + ("%a@{Warning@}: " ^^ fmt ^^ "@.") print t diff --git a/src/errors.mli b/src/errors.mli index e3374837..acad7641 100644 --- a/src/errors.mli +++ b/src/errors.mli @@ -27,3 +27,13 @@ val exnf : Loc.t -> ('a, Format.formatter, unit, exn) format4 -> 'a val fail : Loc.t -> ('a, Format.formatter, unit, 'b ) format4 -> 'a val fail_lex : Lexing.lexbuf -> ('a, Format.formatter, unit, 'b ) format4 -> 'a val fail_opt : Loc.t option -> ('a, Format.formatter, unit, 'b ) format4 -> 'a + +(** Prints "File ..., line ..., characters ...:\n" *) +val print : Format.formatter -> Loc.t -> unit + +(** Prints a warning *) +val warn : Loc.t -> ('a, Format.formatter, unit) format -> 'a + +val print_to_console : string -> unit + +val printer : (string -> unit) ref diff --git a/src/file_tree.ml b/src/file_tree.ml index 3dac1b74..51e66c12 100644 --- a/src/file_tree.ml +++ b/src/file_tree.ml @@ -89,12 +89,12 @@ let load_jbuild_ignore path = if Filename.dirname fn = Filename.current_dir_name then true else begin - Dloc.(warn (Loc.of_pos - ( Path.to_string path - , i + 1, 0 - , String.length fn - )) - "subdirectory expression %s ignored" fn); + Errors.(warn (Loc.of_pos + ( Path.to_string path + , i + 1, 0 + , String.length fn + )) + "subdirectory expression %s ignored" fn); false end) |> String.Set.of_list diff --git a/src/import.ml b/src/import.ml index 08a28ddd..bff4f735 100644 --- a/src/import.ml +++ b/src/import.ml @@ -89,6 +89,4 @@ module No_io = struct module Io = struct end end -(* This is ugly *) -let printer = ref (Printf.eprintf "%s%!") -let print_to_console s = !printer s +let print_to_console = Errors.print_to_console diff --git a/src/lib.ml b/src/lib.ml index 239d99ab..abb5f4aa 100644 --- a/src/lib.ml +++ b/src/lib.ml @@ -1138,7 +1138,7 @@ let report_lib_error ppf (e : Error.t) = | No_solution_found_for_select { loc } -> Format.fprintf ppf "%a@{Error@}: No solution found for this select form.\n" - Dloc.print loc + Errors.print loc | Dependency_cycle cycle -> Format.fprintf ppf "@{Error@}: Dependency cycle detected between the \ diff --git a/src/print_diff.ml b/src/print_diff.ml index 5dad51e5..e32ea735 100644 --- a/src/print_diff.ml +++ b/src/print_diff.ml @@ -16,7 +16,7 @@ let print ?(skip_trailing_cr=Sys.win32) path1 path2 = in let loc = Loc.in_file file1 in let fallback () = - die "%aFiles %s and %s differ." Dloc.print loc + die "%aFiles %s and %s differ." Errors.print loc (Path.to_string_maybe_quoted path1) (Path.to_string_maybe_quoted path2) in @@ -24,7 +24,7 @@ let print ?(skip_trailing_cr=Sys.win32) path1 path2 = match Bin.which "diff" with | None -> fallback () | Some prog -> - Format.eprintf "%a@?" Dloc.print loc; + Format.eprintf "%a@?" Errors.print loc; Process.run ~dir ~env:Env.initial Strict prog (List.concat [ ["-u"] diff --git a/src/report_error.ml b/src/report_error.ml index 38ec4e34..f9ca92e6 100644 --- a/src/report_error.ml +++ b/src/report_error.ml @@ -121,7 +121,7 @@ let report exn = else p.loc in - Option.iter loc ~f:(fun loc -> Dloc.print ppf loc); + Option.iter loc ~f:(fun loc -> Errors.print ppf loc); p.pp ppf; Format.pp_print_flush ppf (); let s = Buffer.contents err_buf in diff --git a/src/scheduler.ml b/src/scheduler.ml index c9b759f4..d5e617dc 100644 --- a/src/scheduler.ml +++ b/src/scheduler.ml @@ -196,7 +196,7 @@ let go ?(log=Log.no_log) ?(config=Config.default) ; waiting_for_available_job = Queue.create () } in - printer := print t; + Errors.printer := print t; let fiber = Fiber.Var.set t_var t (Fiber.with_error_handler (fun () -> fiber) ~on_error:Report_error.report) diff --git a/src/stanza.ml b/src/stanza.ml index 2fe4adbe..b650a102 100644 --- a/src/stanza.ml +++ b/src/stanza.ml @@ -88,7 +88,7 @@ module Of_sexp = struct match Univ_map.find parsing_context (Syntax.key syntax) with | Some (0, _) -> let last = Option.value_exn (List.last entries) in - Dloc.warn (Dsexp.Ast.loc last) + Errors.warn (Dsexp.Ast.loc last) "Field %S is present several times, previous occurrences are ignored." name | _ -> diff --git a/src/super_context.ml b/src/super_context.ml index 24b97235..731319c2 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -856,7 +856,7 @@ module Action = struct assert false | Unnamed v :: _ -> [Path v] | [] -> - Dloc.warn loc "Variable '%s' used with no explicit \ + Errors.warn loc "Variable '%s' used with no explicit \ dependencies@." key; [Value.String ""] end @@ -874,7 +874,7 @@ module Action = struct | [] -> () | x :: _ -> let loc = String_with_vars.loc x in - Dloc.warn loc + Errors.warn loc "Aliases must not have targets, this target will be ignored.\n\ This will become an error in the future."; end;