From 95d9cf0415c1caf6da32d0e6abc0f39afa4edd3f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9mie=20Dimino?= Date: Tue, 15 May 2018 14:07:02 +0100 Subject: [PATCH] Refactor Jbuild.Scope_info.Name and Dune_project.name (#775) --- src/dune_project.ml | 132 ++++++++++++++++-- src/dune_project.mli | 26 +++- src/install_rules.ml | 2 +- src/jbuild.ml | 19 +-- src/jbuild.mli | 16 +-- src/lib.ml | 2 +- src/scope.ml | 7 +- src/scope.mli | 6 +- src/stdune/string.ml | 27 ++-- src/stdune/string.mli | 1 + src/super_context.ml | 4 +- src/super_context.mli | 4 +- .../test-cases/merlin-tests/run.t | 2 +- .../test-cases/ppx-rewriter/run.t | 2 +- 14 files changed, 187 insertions(+), 63 deletions(-) diff --git a/src/dune_project.ml b/src/dune_project.ml index 151e7917..383f7d86 100644 --- a/src/dune_project.ml +++ b/src/dune_project.ml @@ -7,9 +7,113 @@ module Lang = struct | Dune of Syntax.Version.t end +module Name : sig + type t = private + | Named of string + | Anonymous of Path.t + + val compare : t -> t -> Ordering.t + + val to_string_hum : t -> string + + val named_of_sexp : t Sexp.Of_sexp.t + val sexp_of_t : t Sexp.To_sexp.t + + val encode : t -> string + val decode : string -> t + + val anonymous : Path.t -> t option + val named : string -> t option + + val anonymous_root : t +end = struct + type t = + | Named of string + | Anonymous of Path.t + + let anonymous_root = Anonymous Path.root + + let compare a b = + match a, b with + | Named x, Named y -> String.compare x y + | Anonymous x, Anonymous y -> Path.compare x y + | Named _, Anonymous _ -> Lt + | Anonymous _, Named _ -> Gt + + let to_string_hum = function + | Named s -> s + | Anonymous p -> sprintf "" (Path.to_string_maybe_quoted p) + + let sexp_of_t = function + | Named s -> Sexp.To_sexp.string s + | Anonymous p -> + List [ Sexp.unsafe_atom_of_string "anonymous" + ; Path.sexp_of_t p + ] + + let validate name = + let len = String.length name in + len > 0 && + String.for_all name ~f:(function + | '.' | '/' -> false + | _ -> true) + + let named name = + if validate name then + Some (Named name) + else + None + + let anonymous path = + if Path.is_local path then + Some (Anonymous path) + else + None + + let named_of_sexp sexp = + let s = string sexp in + if validate s then + Named s + else + of_sexp_error sexp "invalid project name" + + let encode = function + | Named s -> s + | Anonymous p -> + if Path.is_root p then + "." + else + "." ^ String.map (Path.to_string p) + ~f:(function + | '/' -> '.' + | c -> c) + + let decode = + let invalid s = + (* Users would see this error if they did "dune build + _build/default/.ppx/..." *) + die "Invalid encoded project name: %S" s + in + fun s -> + match s with + | "" -> invalid s + | "." -> anonymous_root + | _ when s.[0] = '.' -> + let p = + Path.of_string + (String.split s ~on:'.' + |> List.tl + |> String.concat ~sep:"/") + in + if not (Path.is_local p) then invalid s; + Anonymous p + | _ when validate s -> Named s + | _ -> invalid s +end + type t = { lang : Lang.t - ; name : string + ; name : Name.t ; root : Path.t ; version : string option ; packages : Package.t Package.Name.Map.t @@ -35,16 +139,26 @@ let lang = let default_name ~dir ~packages = match Package.Name.Map.choose packages with - | None -> - "_" ^ String.concat ~sep:"_" (Path.explode_exn dir) - | Some (name, _) -> - Package.Name.to_string - (Package.Name.Map.fold packages ~init:name ~f:(fun pkg acc -> - min acc pkg.Package.name)) + | None -> Option.value_exn (Name.anonymous dir) + | Some (_, pkg) -> + let pkg = + Package.Name.Map.fold packages ~init:pkg ~f:(fun pkg acc -> + if acc.Package.name <= pkg.Package.name then + acc + else + pkg) + in + let name = Package.Name.to_string pkg.name in + match Name.named name with + | Some x -> x + | None -> + Loc.fail (Loc.in_file (Path.to_string (Package.opam_file pkg))) + "%S is not a valid opam package name." + name let name ~dir ~packages = - field_o "name" string >>= function - | Some s -> return s + field_o "name" Name.named_of_sexp >>= function + | Some x -> return x | None -> return (default_name ~dir ~packages) let parse ~dir packages = diff --git a/src/dune_project.mli b/src/dune_project.mli index 0768b405..d108c695 100644 --- a/src/dune_project.mli +++ b/src/dune_project.mli @@ -8,9 +8,33 @@ module Lang : sig | Dune of Syntax.Version.t end +module Name : sig + (** Invariants: + - Named s -> s <> "" and s does not contain '.' or '/' + - Anonymous p -> p is a local path in the source tree + *) + type t = private + | Named of string + | Anonymous of Path.t + + val compare : t -> t -> Ordering.t + + (** Convert to a string that is suitable for human readable messages *) + val to_string_hum : t -> string + + val sexp_of_t : t -> Sexp.t + + (** Convert to/from an encoded string that is suitable to use in filenames *) + val encode : t -> string + val decode : string -> t + + (** [Anonymous Path.root] *) + val anonymous_root : t +end + type t = { lang : Lang.t - ; name : string + ; name : Name.t ; root : Path.t ; version : string option ; packages : Package.t Package.Name.Map.t diff --git a/src/install_rules.ml b/src/install_rules.ml index d03e4f26..46be5643 100644 --- a/src/install_rules.ml +++ b/src/install_rules.ml @@ -194,7 +194,7 @@ module Gen(P : Install_params) = struct | "ppx_driver" | "ppx_type_conv" -> true | _ -> false) then pps @ [match Scope.name scope with - | Some "ppxlib" -> + | Named "ppxlib" -> Loc.none, Pp.of_string "ppxlib.runner" | _ -> Loc.none, Pp.of_string "ppx_driver.runner"] diff --git a/src/jbuild.ml b/src/jbuild.ml index 02f4cc34..6ec3de68 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -90,20 +90,7 @@ let c_name, cxx_name = make "C++" "cpp") module Scope_info = struct - module Name = struct - type t = string option - - let compare : t -> t -> Ordering.t = compare - - let of_string = function - | "" -> None - | s -> Some s - - let to_string = function - | None -> "" - | Some "" -> assert false - | Some s -> s - end + module Name = Dune_project.Name type t = { name : Name.t @@ -114,7 +101,7 @@ module Scope_info = struct } let anonymous = - { name = None + { name = Name.anonymous_root ; packages = Package.Name.Map.empty ; root = Path.root ; version = None @@ -122,7 +109,7 @@ module Scope_info = struct } let make (project : Dune_project.t) = - { name = Some project.name + { name = project.name ; packages = project.packages ; root = project.root ; version = project.version diff --git a/src/jbuild.mli b/src/jbuild.mli index e76763fa..b64aa387 100644 --- a/src/jbuild.mli +++ b/src/jbuild.mli @@ -10,22 +10,10 @@ module Jbuild_version : sig end module Scope_info : sig - module Name : sig - (* CR-someday diml: change to [private string] and encode [None] - as [""] *) - (** [None] is the for the {!anonymous} scope *) - type t = string option - - val compare : t -> t -> Ordering.t - - val of_string : string -> t - val to_string : t -> string - end + module Name = Dune_project.Name type t = - { name : string option (** First package name in alphabetical - order. [None] for the global - scope. *) + { name : Name.t ; packages : Package.t Package.Name.Map.t ; root : Path.t ; version : string option diff --git a/src/lib.ml b/src/lib.ml index a3967af1..a16630ae 100644 --- a/src/lib.ml +++ b/src/lib.ml @@ -17,7 +17,7 @@ module Status = struct | Installed -> "installed" | Public _ -> "public" | Private s -> - sprintf "private (%s)" (Jbuild.Scope_info.Name.to_string s)) + sprintf "private (%s)" (Jbuild.Scope_info.Name.to_string_hum s)) let is_private = function | Private _ -> true diff --git a/src/scope.ml b/src/scope.ml index 52711100..0b4fad55 100644 --- a/src/scope.ml +++ b/src/scope.ml @@ -42,10 +42,11 @@ module DB = struct | Some x -> x | None -> Exn.code_error "Scope.DB.find_by_name" - [ "name" , Sexp.To_sexp.(option string) name + [ "name" , Dune_project.Name.sexp_of_t name ; "context", Sexp.To_sexp.string t.context ; "names", - Sexp.To_sexp.(list (option string)) (Scope_name_map.keys t.by_name) + Sexp.To_sexp.(list Dune_project.Name.sexp_of_t) + (Scope_name_map.keys t.by_name) ] let create ~scopes ~context ~installed_libs internal_libs = @@ -57,7 +58,7 @@ module DB = struct | Ok x -> x | Error (_name, scope1, scope2) -> let to_sexp (scope : Jbuild.Scope_info.t) = - Sexp.To_sexp.(pair (option string) Path.sexp_of_t) + Sexp.To_sexp.(pair Dune_project.Name.sexp_of_t Path.sexp_of_t) (scope.name, scope.root) in Exn.code_error "Scope.DB.create got two scopes with the same name" diff --git a/src/scope.mli b/src/scope.mli index d34c2bc9..136820b5 100644 --- a/src/scope.mli +++ b/src/scope.mli @@ -7,7 +7,7 @@ open Stdune type t val root : t -> Path.t -val name : t -> string option +val name : t -> Dune_project.Name.t val info : t -> Jbuild.Scope_info.t (** Return the library database associated to this scope *) @@ -28,6 +28,6 @@ module DB : sig -> (Path.t * Jbuild.Library.t) list -> t * Lib.DB.t - val find_by_dir : t -> Path.t -> scope - val find_by_name : t -> string option -> scope + val find_by_dir : t -> Path.t -> scope + val find_by_name : t -> Dune_project.Name.t -> scope end with type scope := t diff --git a/src/stdune/string.ml b/src/stdune/string.ml index 84df85d3..3b6995d7 100644 --- a/src/stdune/string.ml +++ b/src/stdune/string.ml @@ -166,14 +166,24 @@ let longest_map l ~f = let longest l = longest_map l ~f:(fun x -> x) -let exists s ~f = - try - for i=0 to length s - 1 do - if (f s.[i]) then raise_notrace Exit - done; - false - with Exit -> - true + +let exists = + let rec loop s i len f = + if i = len then + false + else + f (unsafe_get s i) || loop s (i + 1) len f + in + fun s ~f -> + loop s 0 (length s) f + +let for_all = + let rec loop s i len f = + i = len || + (f (unsafe_get s i) && loop s (i + 1) len f) + in + fun s ~f -> + loop s 0 (length s) f let maybe_quoted s = let escaped = escaped s in @@ -182,6 +192,5 @@ let maybe_quoted 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 65a267a1..1e2059d7 100644 --- a/src/stdune/string.mli +++ b/src/stdune/string.mli @@ -39,6 +39,7 @@ val longest : string list -> int val longest_map : 'a list -> f:('a -> string) -> int val exists : t -> f:(char -> bool) -> bool +val for_all : 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. *) diff --git a/src/super_context.ml b/src/super_context.ml index e60b6da8..dda22aba 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -536,10 +536,10 @@ module Scope_key = struct (key, public_libs sctx) | Some (key, scope) -> ( key - , Scope.libs (find_scope_by_name sctx (Scope_info.Name.of_string scope))) + , Scope.libs (find_scope_by_name sctx (Scope_info.Name.decode scope))) let to_string key scope = - sprintf "%s@%s" key (Scope_info.Name.to_string scope) + sprintf "%s@%s" key (Scope_info.Name.encode scope) end let parse_bang var : bool * string = diff --git a/src/super_context.mli b/src/super_context.mli index 8ec0286e..542e5149 100644 --- a/src/super_context.mli +++ b/src/super_context.mli @@ -65,8 +65,8 @@ val ocaml_flags (** Dump a directory environment in a readable form *) val dump_env : t -> dir:Path.t -> (unit, Sexp.t list) Build.t -val find_scope_by_dir : t -> Path.t -> Scope.t -val find_scope_by_name : t -> string option -> Scope.t +val find_scope_by_dir : t -> Path.t -> Scope.t +val find_scope_by_name : t -> Dune_project.Name.t -> Scope.t val expand_vars : t diff --git a/test/blackbox-tests/test-cases/merlin-tests/run.t b/test/blackbox-tests/test-cases/merlin-tests/run.t index a6573454..a55c2721 100644 --- a/test/blackbox-tests/test-cases/merlin-tests/run.t +++ b/test/blackbox-tests/test-cases/merlin-tests/run.t @@ -23,7 +23,7 @@ B $LIB_PREFIX/lib/findlib B $LIB_PREFIX/lib/ocaml FLG -open Foo -w -40 -open Bar -w -40 - FLG -ppx '$PPX/fooppx@/ppx.exe --as-ppx --cookie '\''library-name="foo"'\''' + FLG -ppx '$PPX/fooppx@./ppx.exe --as-ppx --cookie '\''library-name="foo"'\''' S . S $LIB_PREFIX/lib/bytes S $LIB_PREFIX/lib/findlib diff --git a/test/blackbox-tests/test-cases/ppx-rewriter/run.t b/test/blackbox-tests/test-cases/ppx-rewriter/run.t index f5fbe1ce..76d09ccf 100644 --- a/test/blackbox-tests/test-cases/ppx-rewriter/run.t +++ b/test/blackbox-tests/test-cases/ppx-rewriter/run.t @@ -3,7 +3,7 @@ ocamlc ppx/.fooppx.objs/fooppx.{cmi,cmo,cmt} ocamlopt ppx/.fooppx.objs/fooppx.{cmx,o} ocamlopt ppx/fooppx.{a,cmxa} - ocamlopt .ppx/fooppx@/ppx.exe + ocamlopt .ppx/fooppx@./ppx.exe ppx w_omp_driver.pp.ml ocamldep w_omp_driver.pp.ml.d ocamlc .w_omp_driver.eobjs/w_omp_driver.{cmi,cmo,cmt}