From 6aa1b84fee24b0b91f90d57225da94434b7c2c9e Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 24 Apr 2018 19:22:41 +0700 Subject: [PATCH] Move Path to Stdune * This requires moving Fatal_error and Loc_error to Stdune.Exn as well * Clflags.workspace_root can no longer be used in Path.to_absolute_filename. We just take a parameter instead for now. --- src/action_intf.ml | 2 ++ src/bin.mli | 2 ++ src/dep_path.mli | 2 ++ src/errors.ml | 5 +++-- src/errors.mli | 11 +---------- src/install_rules.mli | 2 ++ src/jbuild_load.ml | 2 +- src/jbuild_load.mli | 6 +++--- src/loc.ml | 6 ++---- src/loc.mli | 2 -- src/menhir.mli | 2 ++ src/merlin.ml | 2 +- src/modules_partitioner.mli | 2 ++ src/ocaml_flags.mli | 2 ++ src/ocamldep.mli | 2 ++ src/package.ml | 1 + src/package.mli | 2 ++ src/print_diff.mli | 2 ++ src/report_error.ml | 4 ++-- src/scope.mli | 2 ++ src/stdune/exn.ml | 11 +++++++++++ src/stdune/exn.mli | 17 +++++++++++++++++ src/{ => stdune}/path.ml | 13 +++++-------- src/{ => stdune}/path.mli | 14 ++++++-------- src/stdune/stdune.ml | 1 + src/utop.ml | 3 ++- src/utop.mli | 2 ++ test/unit-tests/action.mlt | 2 +- test/unit-tests/path.mlt | 18 +++++++++--------- 29 files changed, 90 insertions(+), 52 deletions(-) rename src/{ => stdune}/path.ml (98%) rename src/{ => stdune}/path.mli (92%) 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/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 d12c1aed..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 @@ -13,4 +14,4 @@ let kerrf fmt ~f = err_ppf fmt 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 d61f0321..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,7 +10,7 @@ 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 (**/**) 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/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 14715838..70122da3 100644 --- a/src/loc.ml +++ b/src/loc.ml @@ -32,16 +32,14 @@ let of_lexbuf 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 diff --git a/src/loc.mli b/src/loc.mli index 7a0bea74..5bcad0cc 100644 --- a/src/loc.mli +++ b/src/loc.mli @@ -7,8 +7,6 @@ val sexp_of_t : t -> Usexp.t val of_lexbuf : Lexing.lexbuf -> t -exception Error of t * string - 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 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/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 762263c8..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 } @@ -55,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 98% rename from src/path.ml rename to src/stdune/path.ml index 153d53f3..4da893c1 100644 --- a/src/path.ml +++ b/src/stdune/path.ml @@ -1,5 +1,3 @@ -open Stdune - let explode_path = let rec loop path acc = let dir = Filename.dirname path in @@ -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 = @@ -280,9 +278,8 @@ let absolute 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 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/stdune/stdune.ml b/src/stdune/stdune.ml index cf1f3241..4fc041f2 100644 --- a/src/stdune/stdune.ml +++ b/src/stdune/stdune.ml @@ -19,6 +19,7 @@ module Staged = Staged module String = String module Char = Char module Sexp = Sexp +module Path = Path external reraise : exn -> _ = "%reraise" 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..32c044a3 100644 --- a/test/unit-tests/path.mlt +++ b/test/unit-tests/path.mlt @@ -8,44 +8,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 -> Jbuilder.Import.Path.t = +- : Jbuilder.Import.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 +- : Jbuilder.Import.Path.t option = None |}] Path.(descendant (r "foo") ~of_:(r "foo/")) [%%expect{| -- : Jbuilder.Path.t option = Some foo +- : Jbuilder.Import.Path.t option = Some foo |}] Path.(descendant (r "foo/") ~of_:(r "foo")) [%%expect{| -- : Jbuilder.Path.t option = Some foo +- : Jbuilder.Import.Path.t option = Some foo |}] Path.(descendant (r "foo/bar") ~of_:(r "foo")) [%%expect{| -- : Jbuilder.Path.t option = Some bar +- : Jbuilder.Import.Path.t option = Some bar |}] Path.(descendant Path.root ~of_:(r "foo")) [%%expect{| -- : Jbuilder.Path.t option = None +- : Jbuilder.Import.Path.t option = None |}] Path.(descendant Path.root ~of_:Path.root) [%%expect{| -- : Jbuilder.Path.t option = Some . +- : Jbuilder.Import.Path.t option = Some . |}] Path.(descendant (r "foo") ~of_:Path.root) [%%expect{| -- : Jbuilder.Path.t option = Some foo +- : Jbuilder.Import.Path.t option = Some foo |}] Path.explode (Path.of_string "a/b/c");