Refactor Jbuild.Scope_info.Name and Dune_project.name (#775)
This commit is contained in:
parent
60c7f6fde4
commit
95d9cf0415
|
@ -7,9 +7,113 @@ module Lang = struct
|
||||||
| Dune of Syntax.Version.t
|
| Dune of Syntax.Version.t
|
||||||
end
|
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 "<anonymous %s>" (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 =
|
type t =
|
||||||
{ lang : Lang.t
|
{ lang : Lang.t
|
||||||
; name : string
|
; name : Name.t
|
||||||
; root : Path.t
|
; root : Path.t
|
||||||
; version : string option
|
; version : string option
|
||||||
; packages : Package.t Package.Name.Map.t
|
; packages : Package.t Package.Name.Map.t
|
||||||
|
@ -35,16 +139,26 @@ let lang =
|
||||||
|
|
||||||
let default_name ~dir ~packages =
|
let default_name ~dir ~packages =
|
||||||
match Package.Name.Map.choose packages with
|
match Package.Name.Map.choose packages with
|
||||||
| None ->
|
| None -> Option.value_exn (Name.anonymous dir)
|
||||||
"_" ^ String.concat ~sep:"_" (Path.explode_exn dir)
|
| Some (_, pkg) ->
|
||||||
| Some (name, _) ->
|
let pkg =
|
||||||
Package.Name.to_string
|
Package.Name.Map.fold packages ~init:pkg ~f:(fun pkg acc ->
|
||||||
(Package.Name.Map.fold packages ~init:name ~f:(fun pkg acc ->
|
if acc.Package.name <= pkg.Package.name then
|
||||||
min acc pkg.Package.name))
|
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 =
|
let name ~dir ~packages =
|
||||||
field_o "name" string >>= function
|
field_o "name" Name.named_of_sexp >>= function
|
||||||
| Some s -> return s
|
| Some x -> return x
|
||||||
| None -> return (default_name ~dir ~packages)
|
| None -> return (default_name ~dir ~packages)
|
||||||
|
|
||||||
let parse ~dir packages =
|
let parse ~dir packages =
|
||||||
|
|
|
@ -8,9 +8,33 @@ module Lang : sig
|
||||||
| Dune of Syntax.Version.t
|
| Dune of Syntax.Version.t
|
||||||
end
|
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 =
|
type t =
|
||||||
{ lang : Lang.t
|
{ lang : Lang.t
|
||||||
; name : string
|
; name : Name.t
|
||||||
; root : Path.t
|
; root : Path.t
|
||||||
; version : string option
|
; version : string option
|
||||||
; packages : Package.t Package.Name.Map.t
|
; packages : Package.t Package.Name.Map.t
|
||||||
|
|
|
@ -194,7 +194,7 @@ module Gen(P : Install_params) = struct
|
||||||
| "ppx_driver" | "ppx_type_conv" -> true
|
| "ppx_driver" | "ppx_type_conv" -> true
|
||||||
| _ -> false) then
|
| _ -> false) then
|
||||||
pps @ [match Scope.name scope with
|
pps @ [match Scope.name scope with
|
||||||
| Some "ppxlib" ->
|
| Named "ppxlib" ->
|
||||||
Loc.none, Pp.of_string "ppxlib.runner"
|
Loc.none, Pp.of_string "ppxlib.runner"
|
||||||
| _ ->
|
| _ ->
|
||||||
Loc.none, Pp.of_string "ppx_driver.runner"]
|
Loc.none, Pp.of_string "ppx_driver.runner"]
|
||||||
|
|
|
@ -90,20 +90,7 @@ let c_name, cxx_name =
|
||||||
make "C++" "cpp")
|
make "C++" "cpp")
|
||||||
|
|
||||||
module Scope_info = struct
|
module Scope_info = struct
|
||||||
module Name = struct
|
module Name = Dune_project.Name
|
||||||
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
|
|
||||||
|
|
||||||
type t =
|
type t =
|
||||||
{ name : Name.t
|
{ name : Name.t
|
||||||
|
@ -114,7 +101,7 @@ module Scope_info = struct
|
||||||
}
|
}
|
||||||
|
|
||||||
let anonymous =
|
let anonymous =
|
||||||
{ name = None
|
{ name = Name.anonymous_root
|
||||||
; packages = Package.Name.Map.empty
|
; packages = Package.Name.Map.empty
|
||||||
; root = Path.root
|
; root = Path.root
|
||||||
; version = None
|
; version = None
|
||||||
|
@ -122,7 +109,7 @@ module Scope_info = struct
|
||||||
}
|
}
|
||||||
|
|
||||||
let make (project : Dune_project.t) =
|
let make (project : Dune_project.t) =
|
||||||
{ name = Some project.name
|
{ name = project.name
|
||||||
; packages = project.packages
|
; packages = project.packages
|
||||||
; root = project.root
|
; root = project.root
|
||||||
; version = project.version
|
; version = project.version
|
||||||
|
|
|
@ -10,22 +10,10 @@ module Jbuild_version : sig
|
||||||
end
|
end
|
||||||
|
|
||||||
module Scope_info : sig
|
module Scope_info : sig
|
||||||
module Name : sig
|
module Name = Dune_project.Name
|
||||||
(* 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
|
|
||||||
|
|
||||||
type t =
|
type t =
|
||||||
{ name : string option (** First package name in alphabetical
|
{ name : Name.t
|
||||||
order. [None] for the global
|
|
||||||
scope. *)
|
|
||||||
; packages : Package.t Package.Name.Map.t
|
; packages : Package.t Package.Name.Map.t
|
||||||
; root : Path.t
|
; root : Path.t
|
||||||
; version : string option
|
; version : string option
|
||||||
|
|
|
@ -17,7 +17,7 @@ module Status = struct
|
||||||
| Installed -> "installed"
|
| Installed -> "installed"
|
||||||
| Public _ -> "public"
|
| Public _ -> "public"
|
||||||
| Private s ->
|
| 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
|
let is_private = function
|
||||||
| Private _ -> true
|
| Private _ -> true
|
||||||
|
|
|
@ -42,10 +42,11 @@ module DB = struct
|
||||||
| Some x -> x
|
| Some x -> x
|
||||||
| None ->
|
| None ->
|
||||||
Exn.code_error "Scope.DB.find_by_name"
|
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
|
; "context", Sexp.To_sexp.string t.context
|
||||||
; "names",
|
; "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 =
|
let create ~scopes ~context ~installed_libs internal_libs =
|
||||||
|
@ -57,7 +58,7 @@ module DB = struct
|
||||||
| Ok x -> x
|
| Ok x -> x
|
||||||
| Error (_name, scope1, scope2) ->
|
| Error (_name, scope1, scope2) ->
|
||||||
let to_sexp (scope : Jbuild.Scope_info.t) =
|
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)
|
(scope.name, scope.root)
|
||||||
in
|
in
|
||||||
Exn.code_error "Scope.DB.create got two scopes with the same name"
|
Exn.code_error "Scope.DB.create got two scopes with the same name"
|
||||||
|
|
|
@ -7,7 +7,7 @@ open Stdune
|
||||||
type t
|
type t
|
||||||
|
|
||||||
val root : t -> Path.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
|
val info : t -> Jbuild.Scope_info.t
|
||||||
|
|
||||||
(** Return the library database associated to this scope *)
|
(** Return the library database associated to this scope *)
|
||||||
|
@ -28,6 +28,6 @@ module DB : sig
|
||||||
-> (Path.t * Jbuild.Library.t) list
|
-> (Path.t * Jbuild.Library.t) list
|
||||||
-> t * Lib.DB.t
|
-> t * Lib.DB.t
|
||||||
|
|
||||||
val find_by_dir : t -> Path.t -> scope
|
val find_by_dir : t -> Path.t -> scope
|
||||||
val find_by_name : t -> string option -> scope
|
val find_by_name : t -> Dune_project.Name.t -> scope
|
||||||
end with type scope := t
|
end with type scope := t
|
||||||
|
|
|
@ -166,14 +166,24 @@ let longest_map l ~f =
|
||||||
|
|
||||||
let longest l = longest_map l ~f:(fun x -> x)
|
let longest l = longest_map l ~f:(fun x -> x)
|
||||||
|
|
||||||
let exists s ~f =
|
|
||||||
try
|
let exists =
|
||||||
for i=0 to length s - 1 do
|
let rec loop s i len f =
|
||||||
if (f s.[i]) then raise_notrace Exit
|
if i = len then
|
||||||
done;
|
false
|
||||||
false
|
else
|
||||||
with Exit ->
|
f (unsafe_get s i) || loop s (i + 1) len f
|
||||||
true
|
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 maybe_quoted s =
|
||||||
let escaped = escaped s in
|
let escaped = escaped s in
|
||||||
|
@ -182,6 +192,5 @@ let maybe_quoted s =
|
||||||
else
|
else
|
||||||
Printf.sprintf {|"%s"|} escaped
|
Printf.sprintf {|"%s"|} escaped
|
||||||
|
|
||||||
|
|
||||||
module Set = Set.Make(T)
|
module Set = Set.Make(T)
|
||||||
module Map = Map.Make(T)
|
module Map = Map.Make(T)
|
||||||
|
|
|
@ -39,6 +39,7 @@ val longest : string list -> int
|
||||||
val longest_map : 'a list -> f:('a -> string) -> int
|
val longest_map : 'a list -> f:('a -> string) -> int
|
||||||
|
|
||||||
val exists : t -> f:(char -> bool) -> bool
|
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
|
(** [maybe_quoted s] is [s] if [s] doesn't need escaping according to OCaml
|
||||||
lexing conventions and [sprintf "%S" s] otherwise. *)
|
lexing conventions and [sprintf "%S" s] otherwise. *)
|
||||||
|
|
|
@ -536,10 +536,10 @@ module Scope_key = struct
|
||||||
(key, public_libs sctx)
|
(key, public_libs sctx)
|
||||||
| Some (key, scope) ->
|
| Some (key, scope) ->
|
||||||
( key
|
( 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 =
|
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
|
end
|
||||||
|
|
||||||
let parse_bang var : bool * string =
|
let parse_bang var : bool * string =
|
||||||
|
|
|
@ -65,8 +65,8 @@ val ocaml_flags
|
||||||
(** Dump a directory environment in a readable form *)
|
(** Dump a directory environment in a readable form *)
|
||||||
val dump_env : t -> dir:Path.t -> (unit, Sexp.t list) Build.t
|
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_dir : t -> Path.t -> Scope.t
|
||||||
val find_scope_by_name : t -> string option -> Scope.t
|
val find_scope_by_name : t -> Dune_project.Name.t -> Scope.t
|
||||||
|
|
||||||
val expand_vars
|
val expand_vars
|
||||||
: t
|
: t
|
||||||
|
|
|
@ -23,7 +23,7 @@
|
||||||
B $LIB_PREFIX/lib/findlib
|
B $LIB_PREFIX/lib/findlib
|
||||||
B $LIB_PREFIX/lib/ocaml
|
B $LIB_PREFIX/lib/ocaml
|
||||||
FLG -open Foo -w -40 -open Bar -w -40
|
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 .
|
||||||
S $LIB_PREFIX/lib/bytes
|
S $LIB_PREFIX/lib/bytes
|
||||||
S $LIB_PREFIX/lib/findlib
|
S $LIB_PREFIX/lib/findlib
|
||||||
|
|
|
@ -3,7 +3,7 @@
|
||||||
ocamlc ppx/.fooppx.objs/fooppx.{cmi,cmo,cmt}
|
ocamlc ppx/.fooppx.objs/fooppx.{cmi,cmo,cmt}
|
||||||
ocamlopt ppx/.fooppx.objs/fooppx.{cmx,o}
|
ocamlopt ppx/.fooppx.objs/fooppx.{cmx,o}
|
||||||
ocamlopt ppx/fooppx.{a,cmxa}
|
ocamlopt ppx/fooppx.{a,cmxa}
|
||||||
ocamlopt .ppx/fooppx@/ppx.exe
|
ocamlopt .ppx/fooppx@./ppx.exe
|
||||||
ppx w_omp_driver.pp.ml
|
ppx w_omp_driver.pp.ml
|
||||||
ocamldep w_omp_driver.pp.ml.d
|
ocamldep w_omp_driver.pp.ml.d
|
||||||
ocamlc .w_omp_driver.eobjs/w_omp_driver.{cmi,cmo,cmt}
|
ocamlc .w_omp_driver.eobjs/w_omp_driver.{cmi,cmo,cmt}
|
||||||
|
|
Loading…
Reference in New Issue