From d9d7792cfb5ef30ee2eca1af3a6094a9c50bb823 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Thu, 23 Aug 2018 11:51:43 +0300 Subject: [PATCH] Move error functions to Errors Signed-off-by: Rudi Grinberg --- src/action.ml | 6 +++--- src/blang.ml | 2 +- src/build_interpret.ml | 4 ++-- src/build_system.ml | 10 +++++----- src/context.ml | 2 +- src/dir_contents.ml | 18 +++++++++--------- src/dloc.ml | 23 ----------------------- src/dloc.mli | 5 ----- src/dune_file.ml | 16 ++++++++-------- src/dune_lexer.mll | 2 +- src/dune_project.ml | 6 +++--- src/errors.ml | 18 ++++++++++++++++++ src/errors.mli | 6 ++++++ src/gen_rules.ml | 6 +++--- src/inline_tests.ml | 2 +- src/install.ml | 2 +- src/installed_dune_file.ml | 6 +++--- src/jbuild_load.ml | 4 ++-- src/lib.ml | 4 ++-- src/lib_rules.ml | 2 +- src/meta.ml | 2 +- src/meta_lexer.mll | 4 ++-- src/opam_file.ml | 4 ++-- src/ordered_set_lang.ml | 12 ++++++------ src/preprocessing.ml | 10 +++++----- src/simple_rules.ml | 6 +++--- src/string_with_vars.ml | 6 +++--- src/sub_system.ml | 6 +++--- src/super_context.ml | 16 ++++++++-------- src/syntax.ml | 10 +++++----- src/utils.ml | 2 +- src/versioned_file.ml | 2 +- src/watermarks.ml | 2 +- src/workspace.ml | 4 ++-- 34 files changed, 113 insertions(+), 117 deletions(-) diff --git a/src/action.ml b/src/action.ml index ace9d9d1..21478740 100644 --- a/src/action.ml +++ b/src/action.ml @@ -441,7 +441,7 @@ module Unexpanded = struct let check_mkdir loc path = if not (Path.is_managed path) then - Dloc.fail loc + Errors.fail loc "(mkdir ...) is not supported for paths outside of the workspace:\n\ \ %a\n" (Dsexp.pp Dune) @@ -596,7 +596,7 @@ module Unexpanded = struct Chdir (res, partial_expand t ~dir ~map_exe ~f) | Right fn -> let loc = String_with_vars.loc fn in - Dloc.fail loc + Errors.fail loc "This directory cannot be evaluated statically.\n\ This is not allowed by dune" end @@ -791,7 +791,7 @@ module Infer = struct match fn with | Left fn -> { acc with targets = Path.Set.add acc.targets fn } | Right sw -> - Dloc.fail (String_with_vars.loc sw) + Errors.fail (String_with_vars.loc sw) "Cannot determine this target statically." let ( +< ) acc fn = match fn with diff --git a/src/blang.ml b/src/blang.ml index 466b539e..0505ee5e 100644 --- a/src/blang.ml +++ b/src/blang.ml @@ -35,7 +35,7 @@ let rec eval_bool t ~dir ~(f : 'a expander) = begin match f.f ~mode:Single a with | _, String "true" -> true | _, String "false" -> false - | loc, _ -> Dloc.fail loc "This value must be either true or false" + | loc, _ -> Errors.fail loc "This value must be either true or false" end | And xs -> List.for_all ~f:(eval_bool ~f ~dir) xs | Or xs -> List.exists ~f:(eval_bool ~f ~dir) xs diff --git a/src/build_interpret.ml b/src/build_interpret.ml index 6ef074e9..5fb251a0 100644 --- a/src/build_interpret.ml +++ b/src/build_interpret.ml @@ -220,7 +220,7 @@ module Rule = struct match targets with | [] -> begin match loc with - | Some loc -> Dloc.fail loc "Rule has no targets specified" + | Some loc -> Errors.fail loc "Rule has no targets specified" | None -> Exn.code_error "Build_interpret.Rule.make: no targets" [] end | x :: l -> @@ -235,7 +235,7 @@ module Rule = struct (List.map targets ~f:Target.path) ] | Some loc -> - Dloc.fail loc + Errors.fail loc "Rule has targets in different directories.\nTargets:\n%s" (String.concat ~sep:"\n" (List.map targets ~f:(fun t -> diff --git a/src/build_system.ml b/src/build_system.ml index 7ed0d465..f2569fba 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -240,7 +240,7 @@ module Alias0 = struct let of_user_written_path ~loc path = if not (Path.is_in_build_dir path) then - Dloc.fail loc "Invalid alias!\n\ + Errors.fail loc "Invalid alias!\n\ Tried to reference path outside build dir: %S" (Path.to_string_maybe_quoted path); { dir = Path.parent_exn path @@ -305,13 +305,13 @@ module Alias0 = struct match File_tree.find_dir file_tree src_dir with | None -> Build.fail { fail = fun () -> - Dloc.fail loc "Don't know about directory %s!" + Errors.fail loc "Don't know about directory %s!" (Path.to_string_maybe_quoted src_dir) } | Some dir -> dep_rec_internal ~name:t.name ~dir ~ctx_dir >>^ fun is_empty -> if is_empty && not (is_standard t.name) then - Dloc.fail loc + Errors.fail loc "This alias is empty.\n\ Alias %S is not defined in %s or any of its descendants." t.name (Path.to_string_maybe_quoted src_dir) @@ -687,7 +687,7 @@ let remove_old_artifacts t ~dir ~subdirs_to_keep = let no_rule_found = let fail fn ~loc = - Dloc.fail_opt loc "No rule found for %s" (Utils.describe_target fn) + Errors.fail_opt loc "No rule found for %s" (Utils.describe_target fn) in fun t ~loc fn -> match Utils.analyse_target fn with @@ -1068,7 +1068,7 @@ and load_dir_step2_exn t ~dir ~collector ~lazy_generators = let present_targets = Path.Set.diff source_files_for_targtes absent_targets in - Dloc.fail + Errors.fail (rule_loc ~file_tree:t.file_tree ~loc:rule.loc diff --git a/src/context.ml b/src/context.ml index b666dbd6..20c97340 100644 --- a/src/context.ml +++ b/src/context.ml @@ -270,7 +270,7 @@ let create ~(kind : Kind.t) ~path ~env ~env_nodes ~name ~merlin ~targets %s" (Path.to_string ocamlc) msg | Error (Makefile_config file, msg) -> - Dloc.fail (Loc.in_file (Path.to_string file)) "%s" msg + Errors.fail (Loc.in_file (Path.to_string file)) "%s" msg in Fiber.fork_and_join findlib_path diff --git a/src/dir_contents.ml b/src/dir_contents.ml index 84f45bd9..7d8f8aa8 100644 --- a/src/dir_contents.ml +++ b/src/dir_contents.ml @@ -40,7 +40,7 @@ end = struct match m with | Ok m -> Some m | Error s -> - Dloc.fail loc "Module %a doesn't exist." Module.Name.pp s) + Errors.fail loc "Module %a doesn't exist." Module.Name.pp s) , modules ) @@ -136,7 +136,7 @@ end = struct |> Option.value_exn in (* CR-soon jdimino for jdimino: report all errors *) - Dloc.fail loc + Errors.fail loc "Module %a has an implementation, it cannot be listed here" Module.Name.pp module_name end @@ -379,7 +379,7 @@ let build_modules_map (d : Super_context.Dir_with_jbuild.t) ~modules = with | Ok x -> x | Error (name, _, (lib2, _)) -> - Dloc.fail lib2.buildable.loc + Errors.fail lib2.buildable.loc "Library %S appears for the second time \ in this directory" name @@ -391,7 +391,7 @@ let build_modules_map (d : Super_context.Dir_with_jbuild.t) ~modules = with | Ok x -> x | Error (name, _, (exes2, _)) -> - Dloc.fail exes2.buildable.loc + Errors.fail exes2.buildable.loc "Executable %S appears for the second time \ in this directory" name @@ -417,7 +417,7 @@ let build_modules_map (d : Super_context.Dir_with_jbuild.t) ~modules = Option.some_if (n = name) b.loc) |> List.sort ~compare in - Dloc.fail (Loc.in_file (List.hd locs).start.pos_fname) + Errors.fail (Loc.in_file (List.hd locs).start.pos_fname) "Module %a is used in several stanzas:@\n\ @[%a@]@\n\ @[%a@]" @@ -478,7 +478,7 @@ let build_mlds_map (d : Super_context.Dir_with_jbuild.t) ~files = | Some s -> s | None -> - Dloc.fail loc "%s.mld doesn't exist in %s" s + Errors.fail loc "%s.mld doesn't exist in %s" s (Path.to_string_maybe_quoted (Path.drop_optional_build_context dir)) ) @@ -514,7 +514,7 @@ module Dir_status = struct match stanza with | Include_subdirs (loc, x) -> if Option.is_some acc then - Dloc.fail loc "The 'include_subdirs' stanza cannot appear \ + Errors.fail loc "The 'include_subdirs' stanza cannot appear \ more than once"; Some x | _ -> acc) @@ -524,7 +524,7 @@ module Dir_status = struct match stanza with | Library { buildable; _} | Executables { buildable; _ } | Tests { exes = { buildable; _ }; _ } -> - Dloc.fail buildable.loc + Errors.fail buildable.loc "This stanza is not allowed in a sub-directory of directory with \ (include_subdirs unqualified).\n\ Hint: add (include_subdirs no) to this file." @@ -664,7 +664,7 @@ let rec get sctx ~dir = ~f:(fun acc (dir, files) -> let modules = modules_of_files ~dir ~files in Module.Name.Map.union acc modules ~f:(fun name x y -> - Dloc.fail (Loc.in_file + Errors.fail (Loc.in_file (Path.to_string (match File_tree.Dir.dune_file ft_dir with | None -> diff --git a/src/dloc.ml b/src/dloc.ml index 36a3cf8c..4f2fcb80 100644 --- a/src/dloc.ml +++ b/src/dloc.ml @@ -3,29 +3,6 @@ open Import include Loc -let of_lexbuf lb = - { Loc.start = Lexing.lexeme_start_p lb - ; stop = Lexing.lexeme_end_p lb - } - -let exnf t fmt = - Format.pp_open_box err_ppf 0; - Format.pp_print_as err_ppf 7 ""; (* "Error: " *) - kerrf (fmt^^ "@]") ~f:(fun s -> Exn.Loc_error (t, s)) - -let fail t fmt = - Format.pp_print_as err_ppf 7 ""; (* "Error: " *) - kerrf fmt ~f:(fun s -> - raise (Exn.Loc_error (t, s))) - -let fail_lex lb fmt = - fail (of_lexbuf lb) fmt - -let fail_opt t fmt = - match t with - | None -> die fmt - | Some t -> fail t fmt - let in_file = Loc.in_file let file_line path n = diff --git a/src/dloc.mli b/src/dloc.mli index d8d7261a..9e49620a 100644 --- a/src/dloc.mli +++ b/src/dloc.mli @@ -5,11 +5,6 @@ type t = Loc.t = ; stop : Lexing.position } -val exnf : t -> ('a, Format.formatter, unit, exn) format4 -> 'a -val fail : t -> ('a, Format.formatter, unit, 'b ) format4 -> 'a -val fail_lex : Lexing.lexbuf -> ('a, Format.formatter, unit, 'b ) format4 -> 'a -val fail_opt : t option -> ('a, Format.formatter, unit, 'b ) format4 -> 'a - val in_file : string -> t val none : t diff --git a/src/dune_file.ml b/src/dune_file.ml index 39bac3e4..13d3becf 100644 --- a/src/dune_file.ml +++ b/src/dune_file.ml @@ -79,9 +79,9 @@ end = struct let validate (loc, res) ~wrapped = match res, wrapped with | Ok s, _ -> s - | Warn _, true -> Dloc.fail loc "%s" wrapped_message + | Warn _, true -> Errors.fail loc "%s" wrapped_message | Warn s, false -> Dloc.warn loc "%s" wrapped_message; s - | Invalid, _ -> Dloc.fail loc "%s" invalid_message + | Invalid, _ -> Errors.fail loc "%s" invalid_message let valid_char = function | 'A'..'Z' | 'a'..'z' | '_' | '0'..'9' -> true @@ -216,7 +216,7 @@ module Pkg = struct and (loc, name) = located Package.Name.dparse in match resolve p name with | Ok x -> x - | Error e -> Dloc.fail loc "%s" e + | Error e -> Errors.fail loc "%s" e let field stanza = map_validate @@ -1253,7 +1253,7 @@ module Executables = struct let mode_to_string mode = " - " ^ Dsexp.to_string ~syntax:Dune (Link_mode.dgen mode) in let mode_strings = List.map ~f:mode_to_string Link_mode.installable_modes in - Dloc.fail + Errors.fail buildable.loc "No installable mode found for %s.\n\ One of the following modes is required:\n\ @@ -1290,7 +1290,7 @@ module Executables = struct let func = match file_kind with | Jbuild -> Dloc.warn - | Dune -> Dloc.fail + | Dune -> Errors.fail in func loc "This field is useless without a (public_name%s ...) field." @@ -1857,7 +1857,7 @@ module Stanzas = struct let dir = Path.parent_exn current_file in let current_file = Path.relative dir fn in if not (Path.exists current_file) then - Dloc.fail loc "File %s doesn't exist." + Errors.fail loc "File %s doesn't exist." (Path.to_string_maybe_quoted current_file); if List.exists include_stack ~f:(fun (_, f) -> Path.equal f current_file) then raise (Include_loop (current_file, include_stack)); @@ -1886,7 +1886,7 @@ module Stanzas = struct (Path.to_string_maybe_quoted file) loc.Loc.start.pos_lnum in - Dloc.fail loc + Errors.fail loc "Recursive inclusion of jbuild files detected:\n\ File %s is included from %s%s" (Path.to_string_maybe_quoted file) @@ -1902,6 +1902,6 @@ module Stanzas = struct ~f:(function Dune_env.T e -> Some e | _ -> None) with | _ :: e :: _ -> - Dloc.fail e.loc "The 'env' stanza cannot appear more than once" + Errors.fail e.loc "The 'env' stanza cannot appear more than once" | _ -> stanzas end diff --git a/src/dune_lexer.mll b/src/dune_lexer.mll index 25db5119..8ef02dff 100644 --- a/src/dune_lexer.mll +++ b/src/dune_lexer.mll @@ -12,7 +12,7 @@ let make_loc lexbuf : Loc.t = let invalid_lang_line start lexbuf = lexbuf.Lexing.lex_start_p <- start; - Dloc.fail_lex lexbuf + Errors.fail_lex lexbuf "Invalid first line, expected: (lang )" } diff --git a/src/dune_project.ml b/src/dune_project.ml index 91a606e8..e73cd855 100644 --- a/src/dune_project.ml +++ b/src/dune_project.ml @@ -225,7 +225,7 @@ module Extension = struct let instantiate ~loc ~parse_args (name_loc, name) (ver_loc, ver) = match Hashtbl.find extensions name with | None -> - Dloc.fail name_loc "Unknown extension %S.%s" name + Errors.fail name_loc "Unknown extension %S.%s" name (hint name (Hashtbl.keys extensions)) | Some t -> Syntax.check_supported t.syntax (ver_loc, ver); @@ -331,7 +331,7 @@ let default_name ~dir ~packages = match Name.named name with | Some x -> x | None -> - Dloc.fail (Loc.in_file (Path.to_string (Package.opam_file pkg))) + Errors.fail (Loc.in_file (Path.to_string (Package.opam_file pkg))) "%S is not a valid opam package name." name @@ -362,7 +362,7 @@ let parse ~dir ~lang ~packages ~file = (Syntax.name e.extension.syntax, e.loc))) with | Error (name, _, loc) -> - Dloc.fail loc "Extension %S specified for the second time." name + Errors.fail loc "Extension %S specified for the second time." name | Ok map -> let project_file : Project_file.t = { file; exists = true } in let extensions = diff --git a/src/errors.ml b/src/errors.ml index 5995b7d8..24114448 100644 --- a/src/errors.ml +++ b/src/errors.ml @@ -15,3 +15,21 @@ let kerrf fmt ~f = let die fmt = kerrf fmt ~f:(fun s -> raise (Exn.Fatal_error s)) + +let exnf t fmt = + Format.pp_open_box err_ppf 0; + Format.pp_print_as err_ppf 7 ""; (* "Error: " *) + kerrf (fmt^^ "@]") ~f:(fun s -> Exn.Loc_error (t, s)) + +let fail t fmt = + Format.pp_print_as err_ppf 7 ""; (* "Error: " *) + kerrf fmt ~f:(fun s -> + raise (Exn.Loc_error (t, s))) + +let fail_lex lb fmt = + fail (Loc.of_lexbuf lb) fmt + +let fail_opt t fmt = + match t with + | None -> die fmt + | Some t -> fail t fmt diff --git a/src/errors.mli b/src/errors.mli index 2860b5e9..e3374837 100644 --- a/src/errors.mli +++ b/src/errors.mli @@ -1,3 +1,4 @@ +open Stdune (** Dealing with errors *) (* CR-soon diml: stop including this in [Import] *) @@ -21,3 +22,8 @@ val kerrf : ('a, Format.formatter, unit, 'b) format4 -> f:(string -> 'b) -> 'a + +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 diff --git a/src/gen_rules.ml b/src/gen_rules.ml index 047e91a5..08563dc9 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -62,11 +62,11 @@ module Gen(P : Install_rules.Params) = struct match Module.Name.Map.find modules mod_name with | Some m -> if not (Module.has_impl m) then - Dloc.fail loc "Module %a has no implementation." + Errors.fail loc "Module %a has no implementation." Module.Name.pp mod_name else { Exe.Program.name; main_module_name = mod_name } - | None -> Dloc.fail loc "Module %a doesn't exist." + | None -> Errors.fail loc "Module %a doesn't exist." Module.Name.pp mod_name) in @@ -296,7 +296,7 @@ module Gen(P : Install_rules.Params) = struct SC.add_rule sctx (Build.fail ~targets { fail = fun () -> - Dloc.fail m.loc + Errors.fail m.loc "I can't determine what library/executable the files \ produced by this stanza are part of." }) diff --git a/src/inline_tests.ml b/src/inline_tests.ml index 5d2a6d45..b1902209 100644 --- a/src/inline_tests.ml +++ b/src/inline_tests.ml @@ -75,7 +75,7 @@ module Backend = struct resolve x >>= fun lib -> match get ~loc lib with | None -> - Error (Dloc.exnf loc "%S is not an %s" name + Error (Errors.exnf loc "%S is not an %s" name (desc ~plural:false)) | Some t -> Ok t)) } diff --git a/src/install.ml b/src/install.ml index 1a2378c0..e6297d8e 100644 --- a/src/install.ml +++ b/src/install.ml @@ -272,7 +272,7 @@ let load_install_file path = ; pos_cnum = col } in - Dloc.fail { start = pos; stop = pos } fmt + Errors.fail { start = pos; stop = pos } fmt in List.concat_map file.file_contents ~f:(function | Variable (pos, section, files) -> begin diff --git a/src/installed_dune_file.ml b/src/installed_dune_file.ml index aa491f8f..b6bc53d1 100644 --- a/src/installed_dune_file.ml +++ b/src/installed_dune_file.ml @@ -17,7 +17,7 @@ let parse_sub_systems ~parsing_context sexps = |> (function | Ok x -> x | Error (name, _, (loc, _, _)) -> - Dloc.fail loc "%S present twice" (Sub_system_name.to_string name)) + Errors.fail loc "%S present twice" (Sub_system_name.to_string name)) |> Sub_system_name.Map.mapi ~f:(fun name (_, version, data) -> let (module M) = Dune_file.Sub_system_info.get name in Syntax.check_supported M.syntax version; @@ -73,10 +73,10 @@ let load fname = | 2, Atom (A "1") -> state := 3; lexer := Dsexp.Lexer.jbuild_token | 2, Atom (A "2") -> state := 3; lexer := Dsexp.Lexer.token | 2, Atom (A version) -> - Dloc.fail (Loc.of_lexbuf lexbuf) "Unsupported version %S" version + Errors.fail (Loc.of_lexbuf lexbuf) "Unsupported version %S" version | 3, _ -> () | _ -> - Dloc.fail (Loc.of_lexbuf lexbuf) + Errors.fail (Loc.of_lexbuf lexbuf) "This .dune file looks invalid, it should \ contain a S-expression of the form (dune x.y ..)" ); diff --git a/src/jbuild_load.ml b/src/jbuild_load.ml index 68e27223..4f1c52f6 100644 --- a/src/jbuild_load.ml +++ b/src/jbuild_load.ml @@ -74,7 +74,7 @@ module Jbuilds = struct (match (kind : File_tree.Dune_file.Kind.t) with | Jbuild -> () | Dune -> - Dloc.fail loc + Errors.fail loc "#require is no longer supported in dune files.\n\ You can use the following function instead of \ Unix.open_process_in:\n\ @@ -85,7 +85,7 @@ module Jbuilds = struct | [] -> acc | ["unix"] -> Unix | _ -> - Dloc.fail loc + Errors.fail loc "Using libraries other that \"unix\" is not supported.\n\ See the manual for details."; in diff --git a/src/lib.ml b/src/lib.ml index df244d5b..239d99ab 100644 --- a/src/lib.ml +++ b/src/lib.ml @@ -320,7 +320,7 @@ exception Error of Error.t let not_available ~loc reason fmt = Errors.kerrf fmt ~f:(fun s -> - Dloc.fail loc "%s %a" s + Errors.fail loc "%s %a" s Error.Library_not_available.Reason.pp reason) (* +-----------------------------------------------------------------+ @@ -492,7 +492,7 @@ module Sub_system = struct | M.Info.T info -> let get ~loc lib' = if lib.unique_id = lib'.unique_id then - Dloc.fail loc "Library %S depends on itself" lib.name + Errors.fail loc "Library %S depends on itself" lib.name else M.get lib' in diff --git a/src/lib_rules.ml b/src/lib_rules.ml index dcb8823d..a3761ea5 100644 --- a/src/lib_rules.ml +++ b/src/lib_rules.ml @@ -227,7 +227,7 @@ module Gen (P : Install_rules.Params) = struct if not (match Path.parent p with | None -> false | Some p -> Path.Set.mem all_dirs p) then - Dloc.fail loc + Errors.fail loc "File %a is not part of the current directory group. \ This is not allowed." Path.pp (Path.drop_optional_build_context p) diff --git a/src/meta.ml b/src/meta.ml index 79de4243..f26722fb 100644 --- a/src/meta.ml +++ b/src/meta.ml @@ -25,7 +25,7 @@ and predicate = | Neg of string module Parse = struct - let error = Dloc.fail_lex + let error = Errors.fail_lex let next = Meta_lexer.token diff --git a/src/meta_lexer.mll b/src/meta_lexer.mll index c8ede951..5f4ca850 100644 --- a/src/meta_lexer.mll +++ b/src/meta_lexer.mll @@ -29,7 +29,7 @@ rule token = parse | '=' { Equal } | "+=" { Plus_equal } | eof { Eof } - | _ { Dloc.fail_lex lexbuf "invalid character" } + | _ { Errors.fail_lex lexbuf "invalid character" } and string buf = parse | '"' @@ -44,4 +44,4 @@ and string buf = parse { Buffer.add_char buf c; string buf lexbuf } | eof - { Dloc.fail_lex lexbuf "unterminated string" } + { Errors.fail_lex lexbuf "unterminated string" } diff --git a/src/opam_file.ml b/src/opam_file.ml index e3a994a4..0dd04b4a 100644 --- a/src/opam_file.ml +++ b/src/opam_file.ml @@ -10,9 +10,9 @@ let load fn = OpamBaseParser.main OpamLexer.token lb (Path.to_string fn) with | OpamLexer.Error msg -> - Dloc.fail_lex lb "%s" msg + Errors.fail_lex lb "%s" msg | Parsing.Parse_error -> - Dloc.fail_lex lb "Parse error") + Errors.fail_lex lb "Parse error") let get_field t name = List.find_map t.file_contents diff --git a/src/ordered_set_lang.ml b/src/ordered_set_lang.ml index af42a7a6..ffe71516 100644 --- a/src/ordered_set_lang.ml +++ b/src/ordered_set_lang.ml @@ -35,7 +35,7 @@ module Parse = struct let open Stanza.Of_sexp in let rec one (kind : Stanza.File_kind.t) = peek_exn >>= function - | Atom (loc, A "\\") -> Dloc.fail loc "unexpected \\" + | Atom (loc, A "\\") -> Errors.fail loc "unexpected \\" | (Atom (_, A "") | Quoted_string (_, _)) | Template _ -> elt | Atom (loc, A s) -> begin @@ -43,10 +43,10 @@ module Parse = struct | ":standard" -> junk >>> return Standard | ":include" -> - Dloc.fail loc + Errors.fail loc "Invalid use of :include, should be: (:include )" | _ when s.[0] = ':' -> - Dloc.fail loc "undefined symbol %s" s + Errors.fail loc "undefined symbol %s" s | _ -> elt end @@ -54,7 +54,7 @@ module Parse = struct match s, kind with | ":include", _ -> inc | s, Dune when s <> "" && s.[0] <> '-' && s.[0] <> ':' -> - Dloc.fail loc + Errors.fail loc "This atom must be quoted because it is the first element \ of a list and doesn't start with - or :" | _ -> enter (many [] kind) @@ -86,7 +86,7 @@ module Parse = struct generic ~elt ~inc:( enter (loc >>= fun loc -> - Dloc.fail loc "(:include ...) is not allowed here")) + Errors.fail loc "(:include ...) is not allowed here")) end @@ -350,7 +350,7 @@ module Unexpanded = struct match f fn with | [x] -> Value.to_path ~dir x | _ -> - Dloc.fail (String_with_vars.loc fn) + Errors.fail (String_with_vars.loc fn) "An unquoted templated expanded to more than one value. \ A file path is expected in this position." in diff --git a/src/preprocessing.ml b/src/preprocessing.ml index 5c9e1b29..02247a26 100644 --- a/src/preprocessing.ml +++ b/src/preprocessing.ml @@ -92,7 +92,7 @@ module Driver = struct resolve x >>= fun lib -> match get ~loc lib with | None -> - Error (Dloc.exnf loc "%S is not a %s" name + Error (Errors.exnf loc "%S is not a %s" name (desc ~plural:false)) | Some t -> Ok t)) } @@ -120,9 +120,9 @@ module Driver = struct let make_error loc msg = match loc with - | User_file (loc, _) -> Error (Dloc.exnf loc "%a" Fmt.text msg) + | User_file (loc, _) -> Error (Errors.exnf loc "%a" Fmt.text msg) | Dot_ppx (path, pps) -> - Error (Dloc.exnf (Loc.in_file (Path.to_string path)) "%a" Fmt.text + Error (Errors.exnf (Loc.in_file (Path.to_string path)) "%a" Fmt.text (sprintf "Failed to create on-demand ppx rewriter for %s; %s" (String.enumerate_and (List.map pps ~f:Pp.to_string)) @@ -437,7 +437,7 @@ let setup_reason_rules sctx (m : Module.t) = | ".re" -> ".re.ml" | ".rei" -> ".re.mli" | _ -> - Dloc.fail + Errors.fail (Loc.in_file (Path.to_string (Path.drop_build_context_exn f.path))) "Unknown file extension for reason source file: %S" @@ -491,7 +491,7 @@ let lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope ~dir_kind = ~scope))) | Pps { loc; pps; flags; staged } -> if staged then - Dloc.fail loc + Errors.fail loc "Staged ppx rewriters cannot be used as linters."; let args : _ Arg_spec.t = S [ As flags diff --git a/src/simple_rules.ml b/src/simple_rules.ml index 0c063268..1d631eae 100644 --- a/src/simple_rules.ml +++ b/src/simple_rules.ml @@ -41,7 +41,7 @@ let copy_files sctx ~dir ~scope ~src_dir (def: Copy_files.t) = ensures that [sources_and_targets_known_so_far] returns the right answer for sub-directories only. *) if not (Path.is_descendant glob_in_src ~of_:src_dir) then - Dloc.fail loc "%s is not a sub-directory of %s" + Errors.fail loc "%s is not a sub-directory of %s" (Path.to_string_maybe_quoted glob_in_src) (Path.to_string_maybe_quoted src_dir); let glob = Path.basename glob_in_src in let src_in_src = Path.parent_exn glob_in_src in @@ -50,11 +50,11 @@ let copy_files sctx ~dir ~scope ~src_dir (def: Copy_files.t) = | Ok re -> Re.compile re | Error (_pos, msg) -> - Dloc.fail (String_with_vars.loc def.glob) "invalid glob: %s" msg + Errors.fail (String_with_vars.loc def.glob) "invalid glob: %s" msg in let file_tree = Super_context.file_tree sctx in if not (File_tree.dir_exists file_tree src_in_src) then - Dloc.fail + Errors.fail loc "cannot find directory: %a" Path.pp src_in_src; diff --git a/src/string_with_vars.ml b/src/string_with_vars.ml index 4e4beae9..e4df3ab0 100644 --- a/src/string_with_vars.ml +++ b/src/string_with_vars.ml @@ -183,7 +183,7 @@ module Partial = struct end let invalid_multivalue (v : var) x = - Dloc.fail v.loc "Variable %s expands to %d values, \ + Errors.fail v.loc "Variable %s expands to %d values, \ however a single value is expected here. \ Please quote this atom." (string_of_var v) (List.length x) @@ -272,9 +272,9 @@ let expand t ~mode ~dir ~f = begin match var.syntax with | Percent -> if Var.is_macro var then - Dloc.fail var.loc "Unknown macro %s" (Var.describe var) + Errors.fail var.loc "Unknown macro %s" (Var.describe var) else - Dloc.fail var.loc "Unknown variable %S" (Var.name var) + Errors.fail var.loc "Unknown variable %S" (Var.name var) | Dollar_brace | Dollar_paren -> Some [Value.String (string_of_var var)] end diff --git a/src/sub_system.ml b/src/sub_system.ml index e5286b71..75e0559a 100644 --- a/src/sub_system.ml +++ b/src/sub_system.ml @@ -40,7 +40,7 @@ module Register_backend(M : Backend) = struct Lib.DB.resolve db (loc, name) >>= fun lib -> match get lib with | None -> - Error (Dloc.exnf loc "%S is not %s %s" name M.desc_article + Error (Errors.exnf loc "%S is not %s %s" name M.desc_article (M.desc ~plural:false)) | Some t -> Ok t @@ -53,7 +53,7 @@ module Register_backend(M : Backend) = struct let to_exn t ~loc = match t with | Too_many_backends backends -> - Dloc.exnf loc + Errors.exnf loc "Too many independent %s found:\n%s" (M.desc ~plural:true) (String.concat ~sep:"\n" @@ -63,7 +63,7 @@ module Register_backend(M : Backend) = struct (Lib.name lib) (Path.to_string_maybe_quoted (Lib.src_dir lib))))) | No_backend_found -> - Dloc.exnf loc "No %s found." (M.desc ~plural:false) + Errors.exnf loc "No %s found." (M.desc ~plural:false) | Other exn -> exn diff --git a/src/super_context.ml b/src/super_context.ml index 8927fafe..24b97235 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -131,7 +131,7 @@ let expand_ocaml_config t pform name = match String.Map.find t.ocaml_config name with | Some x -> x | None -> - Dloc.fail (String_with_vars.Var.loc pform) + Errors.fail (String_with_vars.Var.loc pform) "Unknown ocaml configuration variable %S" name @@ -145,7 +145,7 @@ let expand_vars t ~mode ~scope ~dir ?(bindings=Pform.Map.empty) s = | Macro (Ocaml_config, s) -> expand_ocaml_config t pform s | Var Project_root -> [Value.Dir (Scope.root scope)] | _ -> - Dloc.fail (String_with_vars.Var.loc pform) + Errors.fail (String_with_vars.Var.loc pform) "%s isn't allowed in this position" (String_with_vars.Var.describe pform))) @@ -260,7 +260,7 @@ end = struct let parse_lib_file ~loc s = match String.lsplit2 s ~on:':' with | None -> - Dloc.fail loc "invalid %%{lib:...} form: %s" s + Errors.fail loc "invalid %%{lib:...} form: %s" s | Some x -> x open Build.O @@ -279,10 +279,10 @@ end = struct | Var Targets -> begin match targets_written_by_user with | Infer -> - Dloc.fail loc "You cannot use %s with inferred rules." + Errors.fail loc "You cannot use %s with inferred rules." (String_with_vars.Var.describe pform) | Alias -> - Dloc.fail loc "You cannot use %s in aliases." + Errors.fail loc "You cannot use %s in aliases." (String_with_vars.Var.describe pform) | Static l -> Some (Value.L.dirs l) (* XXX hack to signal no dep *) @@ -348,7 +348,7 @@ end = struct Resolved_forms.add_ddep acc ~key x | None -> Resolved_forms.add_fail acc { fail = fun () -> - Dloc.fail loc + Errors.fail loc "Package %S doesn't exist in the current project." s } end @@ -754,7 +754,7 @@ module Deps = struct Build.paths_glob ~loc ~dir (Re.compile re) >>^ Path.Set.to_list | Error (_pos, msg) -> - Dloc.fail (String_with_vars.loc s) "invalid glob: %s" msg + Errors.fail (String_with_vars.loc s) "invalid glob: %s" msg end | Source_tree s -> let path = expand_vars_path t ~scope ~dir s in @@ -900,7 +900,7 @@ module Action = struct let targets = Path.Set.to_list targets in List.iter targets ~f:(fun target -> if Path.parent_exn target <> targets_dir then - Dloc.fail loc + Errors.fail loc "This action has targets in a different directory than the current \ one, this is not allowed by dune at the moment:\n%s" (List.map targets ~f:(fun target -> diff --git a/src/syntax.ml b/src/syntax.ml index 8e434c0c..0e1a6959 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -28,7 +28,7 @@ module Version = struct try Scanf.sscanf s "%u.%u" (fun a b -> (a, b)) with _ -> - Dloc.fail loc "Atom of the form NNN.NNN expected" + Errors.fail loc "Atom of the form NNN.NNN expected" end | sexp -> of_sexp_error (Dsexp.Ast.loc sexp) "Atom expected" @@ -79,15 +79,15 @@ type t = module Error = struct let since loc t ver ~what = - Dloc.fail loc "%s is only available since version %s of %s" + Errors.fail loc "%s is only available since version %s of %s" what (Version.to_string ver) t.desc let renamed_in loc t ver ~what ~to_ = - Dloc.fail loc "%s was renamed to '%s' in the %s version of %s" + Errors.fail loc "%s was renamed to '%s' in the %s version of %s" what to_ (Version.to_string ver) t.desc let deleted_in loc t ?repl ver ~what = - Dloc.fail loc "%s was deleted in version %s of %s%s" + Errors.fail loc "%s was deleted in version %s of %s%s" what (Version.to_string ver) t.desc (match repl with | None -> "" @@ -106,7 +106,7 @@ let name t = t.name let check_supported t (loc, ver) = if not (Supported_versions.is_supported t.supported_versions ver) then - Dloc.fail loc "Version %s of %s is not supported.\n\ + Errors.fail loc "Version %s of %s is not supported.\n\ Supported versions:\n\ %s" (Version.to_string ver) t.name diff --git a/src/utils.ml b/src/utils.ml index c9c6e612..0f500011 100644 --- a/src/utils.ml +++ b/src/utils.ml @@ -115,7 +115,7 @@ let executable_object_directory ~dir name = Path.relative dir ("." ^ name ^ ".eobjs") let program_not_found ?context ?hint ~loc prog = - Dloc.fail_opt loc + Errors.fail_opt loc "@{Error@}: Program %s not found in the tree or in PATH%s%a" (String.maybe_quoted prog) (match context with diff --git a/src/versioned_file.ml b/src/versioned_file.ml index d83c5615..0fb3c1b2 100644 --- a/src/versioned_file.ml +++ b/src/versioned_file.ml @@ -58,7 +58,7 @@ module Make(Data : sig type t end) = struct (Atom (ver_loc, Dsexp.Atom.of_string ver)) in match Hashtbl.find langs name with | None -> - Dloc.fail name_loc "Unknown language %S.%s" name + Errors.fail name_loc "Unknown language %S.%s" name (hint name (Hashtbl.keys langs)) | Some t -> Syntax.check_supported t.syntax (ver_loc, ver); diff --git a/src/watermarks.ml b/src/watermarks.ml index f87750f4..1ab915ae 100644 --- a/src/watermarks.ml +++ b/src/watermarks.ml @@ -131,7 +131,7 @@ let subst_string s path ~map = loop (i + 1) acc | Some (Error msg) -> let loc = loc_of_offset ~ofs:start ~len:(i + 1 - start) in - Dloc.fail loc "%s" msg + Errors.fail loc "%s" msg end | _ -> loop (i + 1) acc in diff --git a/src/workspace.ml b/src/workspace.ml index 407b58a6..0df91bcd 100644 --- a/src/workspace.ml +++ b/src/workspace.ml @@ -171,13 +171,13 @@ let t ?x ?profile:cmdline_profile () = List.fold_left contexts ~init:None ~f:(fun acc ctx -> let name = Context.name ctx in if String.Set.mem !defined_names name then - Dloc.fail (Context.loc ctx) + Errors.fail (Context.loc ctx) "second definition of build context %S" name; defined_names := String.Set.union !defined_names (String.Set.of_list (Context.all_names ctx)); match ctx, acc with | Opam { merlin = true; _ }, Some _ -> - Dloc.fail (Context.loc ctx) + Errors.fail (Context.loc ctx) "you can only have one context for merlin" | Opam { merlin = true; _ }, None -> Some name