diff --git a/src/action_intf.ml b/src/action_intf.ml index e9fb0709..c5c76f72 100644 --- a/src/action_intf.ml +++ b/src/action_intf.ml @@ -1,3 +1,5 @@ +open Stdune + module Outputs = struct type t = | Stdout diff --git a/src/bin.mli b/src/bin.mli index 18ab90d5..b712ab3e 100644 --- a/src/bin.mli +++ b/src/bin.mli @@ -1,5 +1,7 @@ (** OCaml binaries *) +open Stdune + (** Character used to separate entries in [PATH] and similar environment variables *) val path_sep : char diff --git a/src/binary_kind.ml b/src/binary_kind.ml index 4cde7c91..78174f49 100644 --- a/src/binary_kind.ml +++ b/src/binary_kind.ml @@ -1,3 +1,5 @@ +open Stdune + type t = | Exe | Object diff --git a/src/binary_kind.mli b/src/binary_kind.mli index 462b74f6..707188b4 100644 --- a/src/binary_kind.mli +++ b/src/binary_kind.mli @@ -1,5 +1,7 @@ (** Linking modes for binaries *) +open Stdune + type t = | Exe | Object diff --git a/src/build.ml b/src/build.ml index 1d69484a..4b5078c9 100644 --- a/src/build.ml +++ b/src/build.ml @@ -62,12 +62,16 @@ module Repr = struct let get_if_file_exists_exn state = match !state with | Decided (_, t) -> t - | Undecided _ -> code_errorf "Build.get_if_file_exists_exn: got undecided" + | Undecided _ -> + Exn.code_error "Build.get_if_file_exists_exn: got undecided" [] let get_glob_result_exn state = match !state with | G_evaluated l -> l - | G_unevaluated _ -> code_errorf "Build.get_glob_result_exn: got unevaluated" + | G_unevaluated (loc, path, _) -> + Exn.code_error "Build.get_glob_result_exn: got unevaluated" + [ "loc", Loc.sexp_of_t loc + ; "path", Path.sexp_of_t path ] end include Repr let repr t = t diff --git a/src/build_interpret.ml b/src/build_interpret.ml index 8ae453d2..7144a23b 100644 --- a/src/build_interpret.ml +++ b/src/build_interpret.ml @@ -169,13 +169,19 @@ let targets = | Fail _ -> acc | If_file_exists (_, state) -> begin match !state with - | Decided _ -> code_errorf "Build_interpret.targets got decided if_file_exists" + | Decided (v, _) -> + Exn.code_error "Build_interpret.targets got decided if_file_exists" + ["exists", Sexp.To_sexp.bool v] | Undecided (a, b) -> match loop a [], loop b [] with | [], [] -> acc - | _ -> - code_errorf "Build_interpret.targets: cannot have targets \ - under a [if_file_exists]" + | a, b -> + let targets x = Path.Set.sexp_of_t (Target.paths x) in + Exn.code_error "Build_interpret.targets: cannot have targets \ + under a [if_file_exists]" + [ "targets-a", targets a + ; "targets-b", targets b + ] end | Memo m -> loop m.t acc | Catch (t, _) -> loop t acc diff --git a/src/build_system.ml b/src/build_system.ml index 995c750a..6f9e39c5 100644 --- a/src/build_system.ml +++ b/src/build_system.ml @@ -407,9 +407,11 @@ let entry_point t ~f = (match t.load_dir_stack with | [] -> () - | _ :: _ -> - code_errorf - "Build_system.entry_point: called inside the rule generator callback"); + | stack -> + Exn.code_error + "Build_system.entry_point: called inside the rule generator callback" + ["stack", Sexp.To_sexp.list Path.sexp_of_t stack] + ); f () module Target = Build_interpret.Target @@ -517,7 +519,7 @@ let add_spec t fn spec ~copy_source = As a result, the rule is currently ignored, however this will become an error \ in the future.\n\ %t" - (maybe_quoted (Path.basename fn)) + (String.maybe_quoted (Path.basename fn)) (fun ppf -> match rule.mode with | Not_a_rule_stanza -> diff --git a/src/dep_path.mli b/src/dep_path.mli index 01b853d4..e222737a 100644 --- a/src/dep_path.mli +++ b/src/dep_path.mli @@ -1,5 +1,7 @@ (** Dependency path *) +open Stdune + module Entry : sig type t = | Path of Path.t diff --git a/src/errors.ml b/src/errors.ml index 453f3543..e0f0c527 100644 --- a/src/errors.ml +++ b/src/errors.ml @@ -1,4 +1,5 @@ -exception Fatal_error of string +open Stdune + exception Already_reported let err_buf = Buffer.create 128 @@ -12,8 +13,5 @@ let kerrf fmt ~f = f s) err_ppf fmt -let code_errorf fmt = - kerrf fmt ~f:(fun s -> Stdune.Exn.code_error s []) - let die fmt = - kerrf fmt ~f:(fun s -> raise (Fatal_error s)) + kerrf fmt ~f:(fun s -> raise (Exn.Fatal_error s)) diff --git a/src/errors.mli b/src/errors.mli index cb728d76..2860b5e9 100644 --- a/src/errors.mli +++ b/src/errors.mli @@ -3,15 +3,6 @@ (* CR-soon diml: stop including this in [Import] *) (** This module is included in [Import] *) -(* CR-soon diml: - - Rename to [User_error] - - change the [string] argument to [Loc.t option * string] and get rid of - [Loc.Error]. The two are a bit confusing - - change [string] to [Colors.Style.t Pp.t] -*) -(** A fatal error, that should be reported to the user in a nice way *) -exception Fatal_error of string - (* CR-soon diml: we won't need this once we can generate rules dynamically *) (** Raised for errors that have already been reported to the user and shouldn't be reported again. This might happen when trying to build a dependency that has already @@ -19,12 +10,9 @@ exception Fatal_error of string exception Already_reported (* CR-soon diml: Rename to [user_errorf]. *) -(** Raise a [Fatal_error] exception *) +(** Raise a [Exn.Fatal_error] exception *) val die : ('a, Format.formatter, unit, 'b) format4 -> 'a -(** Raise a [Code_error] exception *) -val code_errorf : ('a, Format.formatter, unit, 'b) format4 -> 'a - (**/**) (* Referenced in Ansi_color and Report_error *) val err_buf : Buffer.t diff --git a/src/import.ml b/src/import.ml index b6b486a2..0fe5989d 100644 --- a/src/import.ml +++ b/src/import.ml @@ -86,15 +86,6 @@ let hint name candidates = sprintf "\nHint: did you mean %s?" (mk_hint l) -(* [maybe_quoted s] is [s] if [s] doesn't need escaping according to OCaml lexing - conventions and [sprintf "%S" s] otherwise. *) -let maybe_quoted s = - let escaped = String.escaped s in - if s == escaped || s = escaped then - s - else - sprintf {|"%s"|} escaped - (* Disable file operations to force to use the IO module *) let open_in = `Use_Io let open_in_bin = `Use_Io diff --git a/src/install.mli b/src/install.mli index 99501d8e..225b0442 100644 --- a/src/install.mli +++ b/src/install.mli @@ -1,5 +1,7 @@ (** Opam install file *) +open Stdune + module Section : sig type t = | Lib diff --git a/src/install_rules.mli b/src/install_rules.mli index 1b6fcb5d..959b95d6 100644 --- a/src/install_rules.mli +++ b/src/install_rules.mli @@ -1,3 +1,5 @@ +open Stdune + module type Params = sig val sctx : Super_context.t end diff --git a/src/installed_dune_file.mli b/src/installed_dune_file.mli index 32532b55..18425920 100644 --- a/src/installed_dune_file.mli +++ b/src/installed_dune_file.mli @@ -1,4 +1,6 @@ (** Dune files that are installed on the system *) +open Stdune + val load : fname:string -> Jbuild.Sub_system_info.t Sub_system_name.Map.t val gen : (Syntax.Version.t * Sexp.t) Sub_system_name.Map.t -> Sexp.t diff --git a/src/jbuild_load.ml b/src/jbuild_load.ml index f1ef80ca..67dd1070 100644 --- a/src/jbuild_load.ml +++ b/src/jbuild_load.ml @@ -136,7 +136,7 @@ end List.concat [ [ "-I"; "+compiler-libs" ] ; cmas - ; [ Path.to_absolute_filename wrapper ] + ; [ Path.to_absolute_filename wrapper ~root:!Clflags.workspace_root ] ] in (* CR-someday jdimino: if we want to allow plugins to use findlib: diff --git a/src/jbuild_load.mli b/src/jbuild_load.mli index addce278..7dc5882e 100644 --- a/src/jbuild_load.mli +++ b/src/jbuild_load.mli @@ -1,4 +1,4 @@ -open Jbuild +open Stdune module Jbuilds : sig type t @@ -6,14 +6,14 @@ module Jbuilds : sig val eval : t -> context:Context.t - -> (Path.t * Scope_info.t * Stanzas.t) list Fiber.t + -> (Path.t * Jbuild.Scope_info.t * Jbuild.Stanzas.t) list Fiber.t end type conf = { file_tree : File_tree.t ; jbuilds : Jbuilds.t ; packages : Package.t Package.Name.Map.t - ; scopes : Scope_info.t list + ; scopes : Jbuild.Scope_info.t list } val load diff --git a/src/loc.ml b/src/loc.ml index 96450d27..70122da3 100644 --- a/src/loc.ml +++ b/src/loc.ml @@ -5,21 +5,41 @@ type t = Usexp.Loc.t = ; stop : Lexing.position } +(* TODO get rid of all this stuff once this parsing code moves to Usexp and + there will be no circular dependency *) +let int n = Usexp.Atom (Usexp.Atom.of_int n) +let string = Usexp.atom_or_quoted_string +let record l = + let open Usexp in + List (List.map l ~f:(fun (n, v) -> List [Atom(Atom.of_string n); v])) + +let sexp_of_position_no_file (p : Lexing.position) = + record + [ "pos_lnum", int p.pos_lnum + ; "pos_bol", int p.pos_bol + ; "pos_cnum", int p.pos_cnum + ] + +let sexp_of_t t = + record (* TODO handle when pos_fname differs *) + [ "pos_fname", string t.start.pos_fname + ; "start", sexp_of_position_no_file t.start + ; "stop", sexp_of_position_no_file t.stop + ] + let of_lexbuf lb = { start = Lexing.lexeme_start_p lb ; stop = Lexing.lexeme_end_p lb } -exception Error of t * string - let exnf t fmt = Format.pp_print_as err_ppf 7 ""; (* "Error: " *) - kerrf fmt ~f:(fun s -> Error (t, s)) + 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 (Error (t, s))) + raise (Exn.Loc_error (t, s))) let fail_lex lb fmt = fail (of_lexbuf lb) fmt @@ -29,17 +49,7 @@ let fail_opt t fmt = | None -> die fmt | Some t -> fail t fmt -let in_file fn = - let pos : Lexing.position = - { pos_fname = fn - ; pos_lnum = 1 - ; pos_cnum = 0 - ; pos_bol = 0 - } - in - { start = pos - ; stop = pos - } +let in_file = Usexp.Loc.in_file let of_pos (fname, lnum, cnum, enum) = let pos : Lexing.position = diff --git a/src/loc.mli b/src/loc.mli index d47e0f40..5bcad0cc 100644 --- a/src/loc.mli +++ b/src/loc.mli @@ -3,9 +3,9 @@ type t = Usexp.Loc.t = ; stop : Lexing.position } -val of_lexbuf : Lexing.lexbuf -> t +val sexp_of_t : t -> Usexp.t -exception Error of t * string +val of_lexbuf : Lexing.lexbuf -> t val exnf : t -> ('a, Format.formatter, unit, exn) format4 -> 'a val fail : t -> ('a, Format.formatter, unit, 'b ) format4 -> 'a diff --git a/src/menhir.mli b/src/menhir.mli index 0699ed1d..23f9ab24 100644 --- a/src/menhir.mli +++ b/src/menhir.mli @@ -1,5 +1,7 @@ (** Menhir rules *) +open Stdune + (** Generate the rules for a [(menhir ...)] stanza. Return the list of targets that are generated by these rules. This list of targets is used by the code that computes the list of modules in the diff --git a/src/merlin.ml b/src/merlin.ml index 68d2d735..72c3314b 100644 --- a/src/merlin.ml +++ b/src/merlin.ml @@ -70,7 +70,7 @@ let ppx_flags sctx ~dir:_ ~scope ~src_dir:_ { preprocess; libname; _ } = | Pps { pps; flags } -> let exe = Preprocessing.get_ppx_driver sctx ~scope pps in let command = - List.map (Path.to_absolute_filename exe + List.map (Path.to_absolute_filename exe ~root:!Clflags.workspace_root :: "--as-ppx" :: Preprocessing.cookie_library_name libname @ flags) diff --git a/src/module.ml b/src/module.ml index b46f85c9..df187f99 100644 --- a/src/module.ml +++ b/src/module.ml @@ -31,7 +31,8 @@ module File = struct let to_ocaml t = match t.syntax with - | OCaml -> code_errorf "to_ocaml: can only convert reason Files" () + | OCaml -> Exn.code_error "to_ocaml: can only convert reason Files" + ["t.name", Sexp.To_sexp.string t.name] | Reason -> { syntax = OCaml ; name = @@ -40,7 +41,9 @@ module File = struct (match Filename.extension t.name with | ".re" -> ".ml" | ".rei" -> ".mli" - | _ -> code_errorf "to_ocaml: unrecognized extension %s" ext ()) + | _ -> Exn.code_error "to_ocaml: unrecognized extension" + [ "name", Sexp.To_sexp.string t.name + ; "ext", Sexp.To_sexp.string ext ]) } end diff --git a/src/modules_partitioner.mli b/src/modules_partitioner.mli index 6168b404..a6bce977 100644 --- a/src/modules_partitioner.mli +++ b/src/modules_partitioner.mli @@ -1,5 +1,7 @@ (** Checks modules partitioning inside a directory *) +open Stdune + type t val create diff --git a/src/ocaml_flags.mli b/src/ocaml_flags.mli index 8ad9ea14..51ddaf6d 100644 --- a/src/ocaml_flags.mli +++ b/src/ocaml_flags.mli @@ -1,5 +1,7 @@ (** OCaml flags *) +open Stdune + type t val make diff --git a/src/ocamldep.mli b/src/ocamldep.mli index 685c23a7..c350c20e 100644 --- a/src/ocamldep.mli +++ b/src/ocamldep.mli @@ -1,5 +1,7 @@ (** ocamldep management *) +open Stdune + module Dep_graph : sig type t diff --git a/src/package.ml b/src/package.ml index a2980349..409fe9be 100644 --- a/src/package.ml +++ b/src/package.ml @@ -1,3 +1,4 @@ +open Stdune module Name = struct include Interned.Make() diff --git a/src/package.mli b/src/package.mli index 6737b100..3cc219f4 100644 --- a/src/package.mli +++ b/src/package.mli @@ -1,5 +1,7 @@ (** Information about a package defined in the workspace *) +open Stdune + module Name : sig type t diff --git a/src/print_diff.mli b/src/print_diff.mli index 3daacf43..e813d059 100644 --- a/src/print_diff.mli +++ b/src/print_diff.mli @@ -1,2 +1,4 @@ +open Stdune + (** Diff two files that are expected not to match. *) val print : Path.t -> Path.t -> _ Fiber.t diff --git a/src/report_error.ml b/src/report_error.ml index dfc801d9..65ce11b3 100644 --- a/src/report_error.ml +++ b/src/report_error.ml @@ -25,7 +25,7 @@ let report_with_backtrace exn = | Some p -> p | None -> match exn with - | Loc.Error (loc, msg) -> + | Exn.Loc_error (loc, msg) -> let loc = { loc with start = { loc.start with pos_fname = !map_fname loc.start.pos_fname } @@ -33,6 +33,19 @@ let report_with_backtrace exn = in let pp ppf = Format.fprintf ppf "@{Error@}: %s\n" msg in { p with loc = Some loc; pp } + | Sexp.Of_sexp.Of_sexp (loc, msg, hint') -> + let loc = + { loc with + start = { loc.start with pos_fname = !map_fname loc.start.pos_fname } + } + in + let pp ppf = Format.fprintf ppf "@{Error@}: %s%s\n" msg + (match hint' with + | None -> "" + | Some { Sexp.Of_sexp. on; candidates } -> + hint on candidates) + in + { p with loc = Some loc; pp } | Usexp.Parser.Error e -> let pos = Usexp.Parser.Error.position e in let msg = Usexp.Parser.Error.message e in @@ -42,7 +55,7 @@ let report_with_backtrace exn = loc = Some loc ; pp = fun ppf -> Format.fprintf ppf "@{Error@}: %s\n" msg } - | Fatal_error msg -> + | Exn.Fatal_error msg -> { p with pp = fun ppf -> if msg.[String.length msg - 1] = '\n' then Format.fprintf ppf "%s" msg diff --git a/src/scope.mli b/src/scope.mli index 55e9c04c..d34c2bc9 100644 --- a/src/scope.mli +++ b/src/scope.mli @@ -1,5 +1,7 @@ (** Scopes *) +open Stdune + (** Representation of a Scope. It contain a library database for all the private libraries in the scope. *) type t diff --git a/src/stdune/exn.ml b/src/stdune/exn.ml index 7520ed44..bf2222db 100644 --- a/src/stdune/exn.ml +++ b/src/stdune/exn.ml @@ -2,10 +2,21 @@ type t = exn exception Code_error of Usexp.t +exception Fatal_error of string + +exception Loc_error of Usexp.Loc.t * string + external raise : exn -> _ = "%raise" external raise_notrace : exn -> _ = "%raise_notrace" external reraise : exn -> _ = "%reraise" +let fatalf ?loc fmt = + Format.ksprintf (fun s -> + match loc with + | None -> raise (Fatal_error s) + | Some loc -> raise (Loc_error (loc, s)) + ) fmt + let protectx x ~f ~finally = match f x with | y -> finally x; y diff --git a/src/stdune/exn.mli b/src/stdune/exn.mli index aba7218a..29753a12 100644 --- a/src/stdune/exn.mli +++ b/src/stdune/exn.mli @@ -4,6 +4,23 @@ shouldn't try to be developer friendly rather than user friendly. *) exception Code_error of Usexp.t + +(* CR-soon diml: + - Rename to [User_error] + - change the [string] argument to [Loc.t option * string] and get rid of + [Loc.Error]. The two are a bit confusing + - change [string] to [Colors.Style.t Pp.t] +*) +(** A fatal error, that should be reported to the user in a nice way *) +exception Fatal_error of string + +exception Loc_error of Usexp.Loc.t * string + +val fatalf + : ?loc:Usexp.Loc.t + -> ('a, unit, string, string, string, 'b) format6 + -> 'a + val code_error : string -> (string * Usexp.t) list -> _ type t = exn diff --git a/src/path.ml b/src/stdune/path.ml similarity index 96% rename from src/path.ml rename to src/stdune/path.ml index 38dd7911..4da893c1 100644 --- a/src/path.ml +++ b/src/stdune/path.ml @@ -1,5 +1,3 @@ -open Import - let explode_path = let rec loop path acc = let dir = Filename.dirname path in @@ -78,7 +76,7 @@ module Local = struct let parent = function | "" -> - code_errorf "Path.Local.parent called on the root" + Exn.code_error "Path.Local.parent called on the root" [] | t -> match String.rindex_from t (String.length t - 1) '/' with | exception Not_found -> "" @@ -86,7 +84,7 @@ module Local = struct let basename = function | "" -> - code_errorf "Path.Local.basename called on the root" + Exn.code_error "Path.Local.basename called on the root" [] | t -> let len = String.length t in match String.rindex_from t (len - 1) '/' with @@ -96,11 +94,11 @@ module Local = struct let relative ?error_loc t path = let rec loop t components = match components with - | [] -> Ok t + | [] -> Result.Ok t | "." :: rest -> loop t rest | ".." :: rest -> begin match t with - | "" -> Error () + | "" -> Result.Error () | t -> loop (parent t) rest end | fn :: rest -> @@ -109,9 +107,9 @@ module Local = struct | _ -> loop (t ^ "/" ^ fn) rest in match loop t (explode_path path) with - | Ok t -> t + | Result.Ok t -> t | Error () -> - Loc.fail_opt error_loc "path outside the workspace: %s from %s" path + Exn.fatalf ?loc:error_loc "path outside the workspace: %s from %s" path (to_string t) let is_canonicalized = @@ -247,7 +245,7 @@ let to_string = function | t -> t let to_string_maybe_quoted t = - maybe_quoted (to_string t) + String.maybe_quoted (to_string t) let root = "" @@ -272,15 +270,16 @@ let of_string ?error_loc s = let t sexp = of_string (Sexp.Of_sexp.string sexp) ~error_loc:(Sexp.Ast.loc sexp) let sexp_of_t t = Sexp.atom_or_quoted_string (to_string t) +let initial_cwd = Sys.getcwd () + let absolute fn = if is_local fn then Filename.concat initial_cwd fn else fn -let to_absolute_filename t = +let to_absolute_filename t ~root = if is_local t then begin - let root = !Clflags.workspace_root in assert (not (Filename.is_relative root)); Filename.concat root (to_string t) end else @@ -466,7 +465,7 @@ let insert_after_build_dir_exn = if not (is_local a) || String.contains b '/' then error a b; match String.lsplit2 a ~on:'/' with | Some ("_build", rest) -> - sprintf "_build/%s/%s" b rest + Printf.sprintf "_build/%s/%s" b rest | _ -> error a b diff --git a/src/path.mli b/src/stdune/path.mli similarity index 92% rename from src/path.mli rename to src/stdune/path.mli index ccc0f15c..37d30150 100644 --- a/src/path.mli +++ b/src/stdune/path.mli @@ -1,5 +1,3 @@ -open Import - (** In the current workspace (anything under the current project root) *) module Local : sig type t @@ -50,7 +48,7 @@ module Map : Map.S with type key = t val kind : t -> Kind.t -val of_string : ?error_loc:Loc.t -> string -> t +val of_string : ?error_loc:Usexp.Loc.t -> string -> t val to_string : t -> string (** [to_string_maybe_quoted t] is [maybe_quoted (to_string t)] *) @@ -61,15 +59,15 @@ val is_root : t -> bool val is_local : t -> bool -val relative : ?error_loc:Loc.t -> t -> string -> t +val relative : ?error_loc:Usexp.Loc.t -> t -> string -> t (** Create an external path. If the argument is relative, assume it is relative to the initial directory jbuilder was launched in. *) val absolute : string -> t -(** Convert a path to an absolute filename. Must be called after the - workspace root has been set. *) -val to_absolute_filename : t -> string +(** Convert a path to an absolute filename. Must be called after the workspace + root has been set. [root] is the root directory of local paths *) +val to_absolute_filename : t -> root:string -> string val reach : t -> from:t -> string val reach_for_running : t -> from:t -> string @@ -147,4 +145,4 @@ val extension : t -> string *) val drop_prefix : t -> prefix:t -> string option -val pp : t Fmt.t +val pp : Format.formatter -> t -> unit diff --git a/src/sexp.ml b/src/stdune/sexp.ml similarity index 90% rename from src/sexp.ml rename to src/stdune/sexp.ml index fca46913..f30bbe52 100644 --- a/src/sexp.ml +++ b/src/stdune/sexp.ml @@ -1,7 +1,4 @@ -open Import - -include (Usexp : module type of struct include Usexp end - with module Loc := Usexp.Loc) +include Usexp let buf_len = 65_536 @@ -122,13 +119,23 @@ module Of_sexp = struct | Quoted_string of Loc.t * string | List of Loc.t * ast list + type hint = + { on: string + ; candidates: string list + } + + exception Of_sexp of Loc.t * string * hint option + type 'a t = ast -> 'a let located f sexp = (Ast.loc sexp, f sexp) - let of_sexp_error sexp str = raise (Loc.Error (Ast.loc sexp, str)) - let of_sexp_errorf sexp fmt = ksprintf (of_sexp_error sexp) fmt + let of_sexp_error ?hint sexp str = raise (Of_sexp (Ast.loc sexp, str, hint)) + let of_sexp_errorf ?hint sexp fmt = Printf.ksprintf (of_sexp_error ?hint sexp) fmt + + let of_sexp_errorf_loc loc fmt = + Printf.ksprintf (fun s -> raise (Of_sexp (loc, s, None))) fmt let raw x = x @@ -178,9 +185,9 @@ module Of_sexp = struct let string_set sexp = String.Set.of_list (list string sexp) let string_map f sexp = match String.Map.of_list (list (pair string f) sexp) with - | Ok x -> x + | Result.Ok x -> x | Error (key, _v1, _v2) -> - of_sexp_error sexp (sprintf "key %S present multiple times" key) + of_sexp_error sexp (Printf.sprintf "key %S present multiple times" key) let string_hashtbl f sexp = let map = string_map f sexp in @@ -243,7 +250,7 @@ module Of_sexp = struct let map_validate parse ~f state = let x, state' = parse state in match f x with - | Ok x -> x, state' + | Result.Ok x -> x, state' | Error msg -> let parsed = Name_map.merge state.unparsed state'.unparsed ~f:(fun _key before after -> @@ -255,14 +262,15 @@ module Of_sexp = struct match Name_map.values parsed |> List.map ~f:(fun f -> Ast.loc f.entry) - |> List.sort ~compare:(fun a b -> compare a.Loc.start.pos_cnum b.start.pos_cnum) + |> List.sort ~compare:(fun a b -> + Int.compare a.Loc.start.pos_cnum b.start.pos_cnum) with | [] -> state.loc | first :: l -> let last = List.fold_left l ~init:first ~f:(fun _ x -> x) in { first with stop = last.stop } in - Loc.fail loc "%s" msg + of_sexp_errorf_loc loc "%s" msg module Short_syntax = struct type 'a t = @@ -272,8 +280,7 @@ module Of_sexp = struct let parse t entry name = match t with - | Not_allowed -> - Loc.fail (Ast.loc entry) "field %s needs a value" name + | Not_allowed -> of_sexp_errorf entry "field %s needs a value" name | This x -> x | Located f -> f (Ast.loc entry) end @@ -290,7 +297,7 @@ module Of_sexp = struct match default with | Some v -> (v, add_known name state) | None -> - Loc.fail state.loc "field %s missing" name + of_sexp_errorf_loc state.loc "field %s missing" name let field_o name ?(short=Short_syntax.Not_allowed) value_of_sexp state = match Name_map.find state.unparsed name with @@ -338,8 +345,8 @@ module Of_sexp = struct | List (_, s :: _) -> s | _ -> assert false in - of_sexp_errorf name_sexp - "Unknown field %s%s" name (hint name state.known) + of_sexp_errorf ~hint:({ on = name ; candidates = state.known}) + name_sexp "Unknown field %s" name type ('a, 'b) rest = | No_rest : ('a, 'a) rest @@ -413,11 +420,11 @@ module Of_sexp = struct | Some cstr -> cstr | None -> of_sexp_errorf sexp - "Unknown constructor %s%s" name - (hint - (String.uncapitalize name) - (List.map cstrs ~f:(fun c -> - String.uncapitalize (C.name c)))) + ~hint:{ on = String.uncapitalize name + ; candidates = List.map cstrs ~f:(fun c -> + String.uncapitalize (C.name c)) + } + "Unknown constructor %s" name let sum cstrs sexp = match sexp with @@ -447,9 +454,8 @@ module Of_sexp = struct | Some (_, value) -> value | None -> of_sexp_errorf sexp - "Unknown value %s%s" s - (hint - (String.uncapitalize s) - (List.map cstrs ~f:(fun (name, _) -> - String.uncapitalize name))) + ~hint:{ on = String.uncapitalize s + ; candidates =List.map cstrs ~f:(fun (name, _) -> + String.uncapitalize name) } + "Unknown value %s" s end diff --git a/src/sexp.mli b/src/stdune/sexp.mli similarity index 90% rename from src/sexp.mli rename to src/stdune/sexp.mli index 7bdeb939..b4cb16fb 100644 --- a/src/sexp.mli +++ b/src/stdune/sexp.mli @@ -1,5 +1,3 @@ -open Import - include module type of struct include Usexp end with module Loc := Usexp.Loc val load : fname:string -> mode:'a Parser.Mode.t -> 'a @@ -59,16 +57,25 @@ module To_sexp : sig val record_fields : field list t end with type sexp := t +module Loc = Usexp.Loc + module Of_sexp : sig type ast = Ast.t = | Atom of Loc.t * Atom.t | Quoted_string of Loc.t * string | List of Loc.t * ast list + type hint = + { on: string + ; candidates: string list + } + + exception Of_sexp of Loc.t * string * hint option + include Combinators with type 'a t = Ast.t -> 'a - val of_sexp_error : Ast.t -> string -> _ - val of_sexp_errorf : Ast.t -> ('a, unit, string, 'b) format4 -> 'a + val of_sexp_error : ?hint:hint -> Ast.t -> string -> _ + val of_sexp_errorf : ?hint:hint -> Ast.t -> ('a, unit, string, 'b) format4 -> 'a val located : 'a t -> (Loc.t * 'a) t @@ -102,7 +109,10 @@ module Of_sexp : sig -> 'a option record_parser val field_b : string -> bool record_parser - val map_validate : 'a record_parser -> f:('a -> ('b, string) result) -> 'b record_parser + val map_validate + : 'a record_parser + -> f:('a -> ('b, string) Result.result) + -> 'b record_parser val ignore_fields : string list -> unit record_parser diff --git a/src/stdune/stdune.ml b/src/stdune/stdune.ml index 90676cd2..4fc041f2 100644 --- a/src/stdune/stdune.ml +++ b/src/stdune/stdune.ml @@ -18,6 +18,8 @@ module Set = Set module Staged = Staged module String = String module Char = Char +module Sexp = Sexp +module Path = Path external reraise : exn -> _ = "%reraise" diff --git a/src/stdune/string.ml b/src/stdune/string.ml index 925def86..84df85d3 100644 --- a/src/stdune/string.ml +++ b/src/stdune/string.ml @@ -175,5 +175,13 @@ let exists s ~f = with Exit -> true +let maybe_quoted s = + let escaped = escaped s in + if s == escaped || s = escaped then + s + else + Printf.sprintf {|"%s"|} escaped + + module Set = Set.Make(T) module Map = Map.Make(T) diff --git a/src/stdune/string.mli b/src/stdune/string.mli index 15f49958..65a267a1 100644 --- a/src/stdune/string.mli +++ b/src/stdune/string.mli @@ -40,5 +40,9 @@ val longest_map : 'a list -> f:('a -> string) -> int val exists : t -> f:(char -> bool) -> bool +(** [maybe_quoted s] is [s] if [s] doesn't need escaping according to OCaml + lexing conventions and [sprintf "%S" s] otherwise. *) +val maybe_quoted : t -> t + module Set : Set.S with type elt = t module Map : Map.S with type key = t diff --git a/src/syntax.mli b/src/syntax.mli index d13bd3e3..219e376c 100644 --- a/src/syntax.mli +++ b/src/syntax.mli @@ -1,3 +1,4 @@ +open Stdune (** Versioned syntaxes *) module Version : sig diff --git a/src/usexp/usexp.ml b/src/usexp/usexp.ml index 7b867464..482d8bdf 100644 --- a/src/usexp/usexp.ml +++ b/src/usexp/usexp.ml @@ -240,7 +240,21 @@ let prepare_formatter ppf = | _ -> n)) } -module Loc = Sexp_ast.Loc +module Loc = struct + include Sexp_ast.Loc + + let in_file fn = + let pos : Lexing.position = + { pos_fname = fn + ; pos_lnum = 1 + ; pos_cnum = 0 + ; pos_bol = 0 + } + in + { start = pos + ; stop = pos + } +end module Ast = struct type t = Sexp_ast.t = diff --git a/src/usexp/usexp.mli b/src/usexp/usexp.mli index 27e03dc7..db782902 100644 --- a/src/usexp/usexp.mli +++ b/src/usexp/usexp.mli @@ -28,6 +28,8 @@ module Loc : sig { start : Lexing.position ; stop : Lexing.position } + + val in_file : string -> t end (** The S-expression type *) diff --git a/src/utils.ml b/src/utils.ml index 801635fe..8189cb65 100644 --- a/src/utils.ml +++ b/src/utils.ml @@ -117,7 +117,7 @@ let executable_object_directory ~dir name = let program_not_found ?context ?hint prog = die "@{Error@}: Program %s not found in the tree or in PATH%s%a" - (maybe_quoted prog) + (String.maybe_quoted prog) (match context with | None -> "" | Some name -> sprintf " (context: %s)" name) @@ -127,7 +127,7 @@ let program_not_found ?context ?hint prog = hint let library_not_found ?context ?hint lib = - die "@{Error@}: Library %s not found%s%a" (maybe_quoted lib) + die "@{Error@}: Library %s not found%s%a" (String.maybe_quoted lib) (match context with | None -> "" | Some name -> sprintf " (context: %s)" name) diff --git a/src/utop.ml b/src/utop.ml index 47a5c311..13394971 100644 --- a/src/utop.ml +++ b/src/utop.ml @@ -11,7 +11,8 @@ let pp_ml fmt include_dirs = let pp_include fmt = let pp_sep fmt () = Format.fprintf fmt "@ ; " in Format.pp_print_list ~pp_sep (fun fmt p -> - Format.fprintf fmt "%S" (Path.to_absolute_filename p) + Format.fprintf fmt "%S" (Path.to_absolute_filename p + ~root:!Clflags.workspace_root) ) fmt in Format.fprintf fmt "@[Clflags.include_dirs :=@ [ %a@ ]@];@." diff --git a/src/utop.mli b/src/utop.mli index 6feabfe1..9cec6544 100644 --- a/src/utop.mli +++ b/src/utop.mli @@ -1,5 +1,7 @@ (** Utop rules *) +open Stdune + val utop_exe : Path.t -> Path.t (** Return the path of the utop bytecode binary inside a directory where some libraries are defined. *) diff --git a/test/unit-tests/action.mlt b/test/unit-tests/action.mlt index 7113aea0..a4a28804 100644 --- a/test/unit-tests/action.mlt +++ b/test/unit-tests/action.mlt @@ -12,7 +12,7 @@ let infer (a : Action.t) = (List.map (Path.Set.to_list x.deps) ~f:Path.to_string, List.map (Path.Set.to_list x.targets) ~f:Path.to_string) [%%expect{| -val p : ?error_loc:Jbuilder.Loc.t -> string -> Jbuilder.Path.t = +val p : ?error_loc:Usexp.Loc.t -> string -> Jbuilder.Import.Path.t = val infer : Jbuilder.Action.t -> string list * string list = |}] diff --git a/test/unit-tests/path.mlt b/test/unit-tests/path.mlt index aabf529b..ffc949ee 100644 --- a/test/unit-tests/path.mlt +++ b/test/unit-tests/path.mlt @@ -1,6 +1,5 @@ (* -*- tuareg -*- *) -open Jbuilder;; -open Import;; +open Stdune;; let r = Path.(relative root);; @@ -8,44 +7,44 @@ let r = Path.(relative root);; Path.(let p = relative root "foo" in descendant p ~of_:p) [%%expect{| -val r : string -> Jbuilder.Path.t = -- : Jbuilder.Path.t option = Some foo +val r : string -> Stdune.Path.t = +- : Stdune.Path.t option = Some foo |}] (* different strings but same length *) Path.(descendant (relative root "foo") ~of_:(relative root "bar")) [%%expect{| -- : Jbuilder.Path.t option = None +- : Stdune.Path.t option = None |}] Path.(descendant (r "foo") ~of_:(r "foo/")) [%%expect{| -- : Jbuilder.Path.t option = Some foo +- : Stdune.Path.t option = Some foo |}] Path.(descendant (r "foo/") ~of_:(r "foo")) [%%expect{| -- : Jbuilder.Path.t option = Some foo +- : Stdune.Path.t option = Some foo |}] Path.(descendant (r "foo/bar") ~of_:(r "foo")) [%%expect{| -- : Jbuilder.Path.t option = Some bar +- : Stdune.Path.t option = Some bar |}] Path.(descendant Path.root ~of_:(r "foo")) [%%expect{| -- : Jbuilder.Path.t option = None +- : Stdune.Path.t option = None |}] Path.(descendant Path.root ~of_:Path.root) [%%expect{| -- : Jbuilder.Path.t option = Some . +- : Stdune.Path.t option = Some . |}] Path.(descendant (r "foo") ~of_:Path.root) [%%expect{| -- : Jbuilder.Path.t option = Some foo +- : Stdune.Path.t option = Some foo |}] Path.explode (Path.of_string "a/b/c");