matthieu
/
dune
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge pull request #1179 from rgrinberg/lib-name 

Introduce Lib_name.t and Lib_name.Local.t types
This commit is contained in:
Rudi Grinberg 2018-08-28 13:33:17 +03:00 committed by GitHub
parent 1cfd805404 f700de1572
commit fc0d99c9bb
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
47 changed files with 633 additions and 450 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
bin/main.ml
View File

@ -583,22 +583,25 @@ let installed_libraries =
let findlib = ctx.findlib in
if na then begin
let pkgs = Findlib.all_unavailable_packages findlib in
let longest = String.longest_map pkgs ~f:fst in
let longest =
String.longest_map pkgs ~f:(fun (n, _) -> Lib_name.to_string n) in
let ppf = Format.std_formatter in
List.iter pkgs ~f:(fun (n, r) ->
Format.fprintf ppf "%-*s -> %a@\n" longest n
Format.fprintf ppf "%-*s -> %a@\n" longest (Lib_name.to_string n)
Findlib.Unavailable_reason.pp r);
Format.pp_print_flush ppf ();
Fiber.return ()
end else begin
let pkgs = Findlib.all_packages findlib in
let max_len = String.longest_map pkgs ~f:Findlib.Package.name in
let max_len = String.longest_map pkgs ~f:(fun n ->
Findlib.Package.name n
|> Lib_name.to_string) in
List.iter pkgs ~f:(fun pkg ->
let ver =
Option.value (Findlib.Package.version pkg) ~default:"n/a"
in
Printf.printf "%-*s (version: %s)\n" max_len
(Findlib.Package.name pkg) ver);
(Lib_name.to_string (Findlib.Package.name pkg)) ver);
Fiber.return ()
end)
in
@ -829,11 +832,11 @@ let clean =
(term, Term.info "clean" ~doc ~man)
let format_external_libs libs =
String.Map.to_list libs
Lib_name.Map.to_list libs
|> List.map ~f:(fun (name, kind) ->
match (kind : Lib_deps_info.Kind.t) with
| Optional -> sprintf "- %s (optional)" name
| Required -> sprintf "- %s" name)
| Optional -> sprintf "- %s (optional)" (Lib_name.to_string name)
| Required -> sprintf "- %s" (Lib_name.to_string name))
|> String.concat ~sep:"\n"
let external_lib_deps =
@ -876,20 +879,20 @@ let external_lib_deps =
| Some x -> x)
in
let externals =
String.Map.filteri lib_deps ~f:(fun name _ ->
not (String.Set.mem internals name))
Lib_name.Map.filteri lib_deps ~f:(fun name _ ->
not (Lib_name.Set.mem internals name))
in
if only_missing then begin
let context =
List.find_exn setup.contexts ~f:(fun c -> c.name = context_name)
in
let missing =
String.Map.filteri externals ~f:(fun name _ ->
Lib_name.Map.filteri externals ~f:(fun name _ ->
not (Findlib.available context.findlib name))
in
if String.Map.is_empty missing then
if Lib_name.Map.is_empty missing then
acc
else if String.Map.for_alli missing
else if Lib_name.Map.for_alli missing
~f:(fun _ kind -> kind = Lib_deps_info.Kind.Optional)
then begin
Format.eprintf
@ -907,13 +910,14 @@ let external_lib_deps =
Hint: try: opam install %s@."
context_name
(format_external_libs missing)
(String.Map.to_list missing
(Lib_name.Map.to_list missing
|> List.filter_map ~f:(fun (name, kind) ->
match (kind : Lib_deps_info.Kind.t) with
| Optional -> None
| Required -> Some (Findlib.root_package_name name))
|> String.Set.of_list
|> String.Set.to_list
| Required -> Some (Lib_name.package_name name))
|> Package.Name.Set.of_list
|> Package.Name.Set.to_list
|> List.map ~f:Package.Name.to_string
|> String.concat ~sep:" ");
true
end

24
src/artifacts.ml
View File

@ -75,20 +75,18 @@ let file_of_lib t ~loc ~lib ~file =
match Lib.DB.find t.public_libs lib with
| Error reason ->
Error { fail = fun () ->
Lib.not_available ~loc reason "Public library %S" lib }
Lib.not_available ~loc reason "Public library %a" Lib_name.pp_quoted lib }
| Ok lib ->
if Lib.is_local lib then begin
match String.split (Lib.name lib) ~on:'.' with
| [] -> assert false
| package :: rest ->
let lib_install_dir =
Config.local_install_lib_dir ~context:t.context.name ~package
in
let lib_install_dir =
match rest with
| [] -> lib_install_dir
| _ -> Path.relative lib_install_dir (String.concat rest ~sep:"/")
in
Ok (Path.relative lib_install_dir file)
let (package, rest) = Lib_name.split (Lib.name lib) in
let lib_install_dir =
Config.local_install_lib_dir ~context:t.context.name ~package
in
let lib_install_dir =
match rest with
| [] -> lib_install_dir
| _ -> Path.relative lib_install_dir (String.concat rest ~sep:"/")
in
Ok (Path.relative lib_install_dir file)
end else
Ok (Path.relative (Lib.src_dir lib) file)

2
src/artifacts.mli
View File

@ -26,6 +26,6 @@ val binary
val file_of_lib
: t
-> loc:Loc.t
-> lib:string
-> lib:Lib_name.t
-> file:string
-> (Path.t, fail) result

2
src/build_interpret.ml
View File

@ -156,7 +156,7 @@ let lib_deps =
| Catch (t, _) -> loop t acc
| Lazy_no_targets t -> loop (Lazy.force t) acc
in
fun t -> loop (Build.repr t) String.Map.empty
fun t -> loop (Build.repr t) Lib_name.Map.empty
let targets =
let rec loop : type a b. (a, b) t -> Target.t list -> Target.t list = fun t acc ->

6
src/build_system.ml
View File

@ -1332,7 +1332,7 @@ let all_lib_deps t ~request =
List.fold_left (rules_for_targets t targets) ~init:Path.Map.empty
~f:(fun acc rule ->
let deps = Internal_rule.lib_deps rule in
if String.Map.is_empty deps then
if Lib_name.Map.is_empty deps then
acc
else
let deps =
@ -1347,7 +1347,7 @@ let all_lib_deps_by_context t ~request =
let rules = rules_for_targets t targets in
List.fold_left rules ~init:[] ~f:(fun acc rule ->
let deps = Internal_rule.lib_deps rule in
if String.Map.is_empty deps then
if Lib_name.Map.is_empty deps then
acc
else
match Path.extract_build_context rule.dir with
@ -1356,7 +1356,7 @@ let all_lib_deps_by_context t ~request =
|> String.Map.of_list_multi
|> String.Map.filteri ~f:(fun ctx _ -> String.Map.mem t.contexts ctx)
|> String.Map.map ~f:(function
| [] -> String.Map.empty
| [] -> Lib_name.Map.empty
| x :: l -> List.fold_left l ~init:x ~f:Lib_deps_info.merge)
module Rule = struct

2
src/config.ml
View File

@ -14,7 +14,7 @@ let local_install_man_dir ~context =
let local_install_lib_dir ~context ~package =
Path.relative
(Path.relative (local_install_dir ~context) "lib")
package
(Package.Name.to_string package)
let dev_null =
Path.of_filename_relative_to_initial_cwd

2
src/config.mli
View File

@ -7,7 +7,7 @@ val local_install_dir : context:string -> Path.t
val local_install_bin_dir : context:string -> Path.t
val local_install_man_dir : context:string -> Path.t
val local_install_lib_dir : context:string -> package:string -> Path.t
val local_install_lib_dir : context:string -> package:Package.Name.t -> Path.t
val dev_null : Path.t

9
src/dep_path.ml
View File

@ -4,19 +4,20 @@ module Entry = struct
type t =
| Path of Path.t
| Alias of Path.t
| Library of Path.t * string
| Preprocess of string list
| Library of Path.t * Lib_name.t
| Preprocess of Lib_name.t list
| Loc of Loc.t
let to_string = function
| Path p -> Utils.describe_target p
| Alias p -> "alias " ^ Utils.describe_target p
| Library (path, lib_name) ->
sprintf "library %S in %s" lib_name (Path.to_string_maybe_quoted path)
Format.asprintf "library %a in %s" Lib_name.pp_quoted lib_name
(Path.to_string_maybe_quoted path)
| Preprocess l ->
Sexp.to_string
(List [ Atom "pps"
; Sexp.To_sexp.(list string) l])
; Sexp.To_sexp.(list Lib_name.to_sexp) l])
| Loc loc ->
Loc.to_file_colon_line loc

4
src/dep_path.mli
View File

@ -6,8 +6,8 @@ module Entry : sig
type t =
| Path of Path.t
| Alias of Path.t
| Library of Path.t * string
| Preprocess of string list
| Library of Path.t * Lib_name.t
| Preprocess of Lib_name.t list
| Loc of Loc.t
val to_string : t -> string

28
src/dir_contents.ml
View File

@ -179,7 +179,8 @@ end = struct
}
let make (lib : Library.t) ~dir (modules : Module.t Module.Name.Map.t) =
let main_module_name = Module.Name.of_string lib.name in
let main_module_name =
Module.Name.of_string (Lib_name.Local.to_string lib.name) in
let modules =
if not lib.wrapped then
modules
@ -192,6 +193,7 @@ end = struct
Module.with_wrapper m ~libname:lib.name)
in
let alias_module =
let lib_name = Lib_name.Local.to_string lib.name in
if not lib.wrapped ||
(Module.Name.Map.cardinal modules = 1 &&
Module.Name.Map.mem modules main_module_name) then
@ -204,14 +206,14 @@ end = struct
Some
(Module.make (Module.Name.add_suffix main_module_name "__")
~impl:(Module.File.make OCaml
(Path.relative dir (sprintf "%s__.ml-gen" lib.name)))
~obj_name:(lib.name ^ "__"))
(Path.relative dir (sprintf "%s__.ml-gen" lib_name)))
~obj_name:(lib_name ^ "__"))
else
Some
(Module.make main_module_name
~impl:(Module.File.make OCaml
(Path.relative dir (lib.name ^ ".ml-gen")))
~obj_name:lib.name)
(Path.relative dir (lib_name ^ ".ml-gen")))
~obj_name:lib_name)
in
{ modules; alias_module; main_module_name }
end
@ -221,14 +223,14 @@ module Executables_modules = struct
end
type modules =
{ libraries : Library_modules.t String.Map.t
{ libraries : Library_modules.t Lib_name.Map.t
; executables : Executables_modules.t String.Map.t
; (* Map from modules to the buildable they are part of *)
rev_map : Buildable.t Module.Name.Map.t
}
let empty_modules =
{ libraries = String.Map.empty
{ libraries = Lib_name.Map.empty
; executables = String.Map.empty
; rev_map = Module.Name.Map.empty
}
@ -259,12 +261,12 @@ let text_files t = t.text_files
let modules_of_library t ~name =
let map = (Lazy.force t.modules).libraries in
match String.Map.find map name with
match Lib_name.Map.find map name with
| Some m -> m
| None ->
Exn.code_error "Dir_contents.modules_of_library"
[ "name", Sexp.To_sexp.string name
; "available", Sexp.To_sexp.(list string) (String.Map.keys map)
[ "name", Lib_name.to_sexp name
; "available", Sexp.To_sexp.(list Lib_name.to_sexp) (Lib_name.Map.keys map)
]
let modules_of_executables t ~first_exe =
@ -383,14 +385,14 @@ let build_modules_map (d : Super_context.Dir_with_jbuild.t) ~modules =
in
let libraries =
match
String.Map.of_list_map libs ~f:(fun (lib, m) -> Library.best_name lib, m)
Lib_name.Map.of_list_map libs ~f:(fun (lib, m) -> Library.best_name lib, m)
with
| Ok x -> x
| Error (name, _, (lib2, _)) ->
Errors.fail lib2.buildable.loc
"Library %S appears for the second time \
"Library %a appears for the second time \
in this directory"
name
Lib_name.pp_quoted name
in
let executables =
match

2
src/dir_contents.mli
View File

@ -29,7 +29,7 @@ module Executables_modules : sig
end
(** Modules attached to a library. [name] is the library best name. *)
val modules_of_library : t -> name:string -> Library_modules.t
val modules_of_library : t -> name:Lib_name.t -> Library_modules.t
(** Modules attached to a set of executables. *)
val modules_of_executables : t -> first_exe:string -> Executables_modules.t

217
src/dune_file.ml
View File

@ -38,82 +38,6 @@ let module_name =
let module_names = list module_name >>| String.Set.of_list
module Lib_name : sig
type t
type result =
| Ok of t
| Warn of t
| Invalid
val invalid_message : string
val to_string : t -> string
val of_string : string -> result
val validate : (Loc.t * result) -> wrapped:bool -> t
val dparse : (Loc.t * result) Dsexp.Of_sexp.t
end = struct
type t = string
let invalid_message =
"invalid library name.\n\
Hint: library names must be non-empty and composed only of \
the following characters: 'A'..'Z', 'a'..'z', '_' or '0'..'9'"
let wrapped_message =
sprintf
"%s.\n\
This is temporary allowed for libraries with (wrapped false).\
\nIt will not be supported in the future. \
Please choose a valid name field."
invalid_message
type result =
| Ok of t
| Warn of t
| Invalid
let validate (loc, res) ~wrapped =
match res, wrapped with
| Ok s, _ -> s
| Warn _, true -> Errors.fail loc "%s" wrapped_message
| Warn s, false -> Errors.warn loc "%s" wrapped_message; s
| Invalid, _ -> Errors.fail loc "%s" invalid_message
let valid_char = function
| 'A'..'Z' | 'a'..'z' | '_' | '0'..'9' -> true
| _ -> false
let to_string s = s
let of_string name =
match name with
| "" -> Invalid
| s ->
if s.[0] = '.' then
Invalid
else
let len = String.length s in
let rec loop warn i =
if i = len - 1 then
if warn then Warn s else Ok s
else
let c = String.unsafe_get s i in
if valid_char c then
loop warn (i + 1)
else if c = '.' then
loop true (i + 1)
else
Invalid
in
loop false 0
let dparse = plain_string (fun ~loc s -> (loc, of_string s))
end
let file =
plain_string (fun ~loc s ->
match s with
@ -230,20 +154,23 @@ module Pkg = struct
end
module Pp : sig
type t = private string
val of_string : string -> t
type t = private Lib_name.t
val of_string : loc:Loc.t option -> string -> t
val to_string : t -> string
val compare : t -> t -> Ordering.t
val to_lib_name : t -> Lib_name.t
end = struct
type t = string
type t = Lib_name.t
let of_string s =
let to_lib_name s = s
let of_string ~loc s =
assert (not (String.is_prefix s ~prefix:"-"));
s
Lib_name.of_string_exn ~loc s
let to_string t = t
let to_string = Lib_name.to_string
let compare = String.compare
let compare = Lib_name.compare
end
module Pps_and_flags = struct
@ -252,7 +179,7 @@ module Pps_and_flags = struct
if String.is_prefix s ~prefix:"-" then
Right [s]
else
Left (loc, Pp.of_string s)
Left (loc, Pp.of_string ~loc:(Some loc) s)
let item =
peek_exn >>= function
@ -282,7 +209,7 @@ module Pps_and_flags = struct
if String.is_prefix s ~prefix:"-" then
Right s
else
Left (loc, Pp.of_string s))
Left (loc, Pp.of_string ~loc:(Some loc) s))
in
(pps, more_flags @ Option.value flags ~default:[])
end
@ -591,8 +518,8 @@ end
module Lib_dep = struct
type choice =
{ required : String.Set.t
; forbidden : String.Set.t
{ required : Lib_name.Set.t
; forbidden : Lib_name.Set.t
; file : string
}
@ -603,7 +530,7 @@ module Lib_dep = struct
}
type t =
| Direct of (Loc.t * string)
| Direct of (Loc.t * Lib_name.t)
| Select of select
let choice =
@ -611,12 +538,14 @@ module Lib_dep = struct
let%map loc = loc
and preds, file =
until_keyword "->"
~before:(let%map s = string in
~before:(let%map s = string
and loc = loc in
let len = String.length s in
if len > 0 && s.[0] = '!' then
Right (String.drop s 1)
Right (Lib_name.of_string_exn ~loc:(Some loc)
(String.drop s 1))
else
Left s)
Left (Lib_name.of_string_exn ~loc:(Some loc) s))
~after:file
in
match file with
@ -625,21 +554,21 @@ module Lib_dep = struct
| Some file ->
let rec loop required forbidden = function
| [] ->
let common = String.Set.inter required forbidden in
Option.iter (String.Set.choose common) ~f:(fun name ->
let common = Lib_name.Set.inter required forbidden in
Option.iter (Lib_name.Set.choose common) ~f:(fun name ->
of_sexp_errorf loc
"library %S is both required and forbidden in this clause"
name);
(Lib_name.to_string name));
{ required
; forbidden
; file
}
| Left s :: l ->
loop (String.Set.add required s) forbidden l
loop (Lib_name.Set.add required s) forbidden l
| Right s :: l ->
loop required (String.Set.add forbidden s) l
loop required (Lib_name.Set.add forbidden s) l
in
loop String.Set.empty String.Set.empty preds)
loop Lib_name.Set.empty Lib_name.Set.empty preds)
let dparse =
if_list
@ -651,18 +580,20 @@ module Lib_dep = struct
and () = keyword "from"
and choices = repeat choice in
Select { result_fn; choices; loc }))
~else_:(plain_string (fun ~loc s -> Direct (loc, s)))
~else_:(
let%map (loc, name) = located Lib_name.dparse in
Direct (loc, name))
let to_lib_names = function
| Direct (_, s) -> [s]
| Select s ->
List.fold_left s.choices ~init:String.Set.empty ~f:(fun acc x ->
String.Set.union acc (String.Set.union x.required x.forbidden))
|> String.Set.to_list
List.fold_left s.choices ~init:Lib_name.Set.empty ~f:(fun acc x ->
Lib_name.Set.union acc (Lib_name.Set.union x.required x.forbidden))
|> Lib_name.Set.to_list
let direct x = Direct x
let of_pp (loc, pp) = Direct (loc, Pp.to_string pp)
let of_pp (loc, pp) = Direct (loc, Pp.to_lib_name pp)
end
module Lib_deps = struct
@ -678,36 +609,37 @@ module Lib_deps = struct
and t = repeat Lib_dep.dparse
in
let add kind name acc =
match String.Map.find acc name with
| None -> String.Map.add acc name kind
match Lib_name.Map.find acc name with
| None -> Lib_name.Map.add acc name kind
| Some kind' ->
match kind, kind' with
| Required, Required ->
of_sexp_errorf loc "library %S is present twice" name
of_sexp_errorf loc "library %S is present twice"
(Lib_name.to_string name)
| (Optional|Forbidden), (Optional|Forbidden) ->
acc
| Optional, Required | Required, Optional ->
of_sexp_errorf loc
"library %S is present both as an optional \
and required dependency"
name
(Lib_name.to_string name)
| Forbidden, Required | Required, Forbidden ->
of_sexp_errorf loc
"library %S is present both as a forbidden \
and required dependency"
name
(Lib_name.to_string name)
in
ignore (
List.fold_left t ~init:String.Map.empty ~f:(fun acc x ->
List.fold_left t ~init:Lib_name.Map.empty ~f:(fun acc x ->
match x with
| Lib_dep.Direct (_, s) -> add Required s acc
| Select { choices; _ } ->
List.fold_left choices ~init:acc ~f:(fun acc c ->
let acc =
String.Set.fold c.Lib_dep.required ~init:acc ~f:(add Optional)
Lib_name.Set.fold c.Lib_dep.required ~init:acc ~f:(add Optional)
in
String.Set.fold c.forbidden ~init:acc ~f:(add Forbidden)))
: kind String.Map.t);
Lib_name.Set.fold c.forbidden ~init:acc ~f:(add Forbidden)))
: kind Lib_name.Map.t);
t
let dparse = parens_removed_in_dune dparse
@ -721,9 +653,9 @@ module Lib_deps = struct
| Lib_dep.Direct (_, s) -> [(s, kind)]
| Select { choices; _ } ->
List.concat_map choices ~f:(fun c ->
String.Set.to_list c.Lib_dep.required
Lib_name.Set.to_list c.Lib_dep.required
|> List.map ~f:(fun d -> (d, Lib_deps_info.Kind.Optional))))
|> String.Map.of_list_reduce ~f:Lib_deps_info.Kind.merge
|> Lib_name.Map.of_list_reduce ~f:Lib_deps_info.Kind.merge
end
module Buildable = struct
@ -786,7 +718,7 @@ end
module Public_lib = struct
type t =
{ name : Loc.t * string
{ name : Loc.t * Lib_name.t
; package : Package.t
; sub_dir : string option
}
@ -796,25 +728,23 @@ module Public_lib = struct
let public_name_field =
map_validate
(let%map project = Dune_project.get_exn ()
and loc_name = field_o "public_name" (located string) in
and loc_name = field_o "public_name" (located Lib_name.dparse) in
(project, loc_name))
~f:(fun (project, loc_name) ->
match loc_name with
| None -> Ok None
| Some ((_, s) as loc_name) ->
match String.split s ~on:'.' with
| [] -> assert false
| pkg :: rest ->
match Pkg.resolve project (Package.Name.of_string pkg) with
| Ok pkg ->
Ok (Some
{ package = pkg
; sub_dir =
if rest = [] then None else
Some (String.concat rest ~sep:"/")
; name = loc_name
})
| Error _ as e -> e)
let (pkg, rest) = Lib_name.split s in
match Pkg.resolve project pkg with
| Ok pkg ->
Ok (Some
{ package = pkg
; sub_dir =
if rest = [] then None else
Some (String.concat rest ~sep:"/")
; name = loc_name
})
| Error _ as e -> e)
end
module Sub_system_info = struct
@ -919,11 +849,11 @@ module Library = struct
end
type t =
{ name : string
{ name : Lib_name.Local.t
; public : Public_lib.t option
; synopsis : string option
; install_c_headers : string list
; ppx_runtime_libraries : (Loc.t * string) list
; ppx_runtime_libraries : (Loc.t * Lib_name.t) list
; modes : Mode_conf.Set.t
; kind : Kind.t
; c_flags : Ordered_set_lang.Unexpanded.t
@ -933,7 +863,7 @@ module Library = struct
; library_flags : Ordered_set_lang.Unexpanded.t
; c_library_flags : Ordered_set_lang.Unexpanded.t
; self_build_stubs_archive : string option
; virtual_deps : (Loc.t * string) list
; virtual_deps : (Loc.t * Lib_name.t) list
; wrapped : bool
; optional : bool
; buildable : Buildable.t
@ -948,13 +878,13 @@ module Library = struct
record
(let%map buildable = Buildable.dparse
and loc = loc
and name = field_o "name" Lib_name.dparse
and name = field_o "name" Lib_name.Local.dparse_loc
and public = Public_lib.public_name_field
and synopsis = field_o "synopsis" string
and install_c_headers =
field "install_c_headers" (list string) ~default:[]
and ppx_runtime_libraries =
field "ppx_runtime_libraries" (list (located string)) ~default:[]
field "ppx_runtime_libraries" (list (located Lib_name.dparse)) ~default:[]
and c_flags = field_oslu "c_flags"
and cxx_flags = field_oslu "cxx_flags"
and c_names = field "c_names" (list c_name) ~default:[]
@ -962,7 +892,7 @@ module Library = struct
and library_flags = field_oslu "library_flags"
and c_library_flags = field_oslu "c_library_flags"
and virtual_deps =
field "virtual_deps" (list (located string)) ~default:[]
field "virtual_deps" (list (located Lib_name.dparse)) ~default:[]
and modes = field "modes" Mode_conf.Set.dparse ~default:Mode_conf.Set.default
and kind = field "kind" Kind.dparse ~default:Kind.Normal
and wrapped = field "wrapped" bool ~default:true
@ -981,19 +911,18 @@ module Library = struct
let open Syntax.Version.Infix in
match name, public with
| Some n, _ ->
Lib_name.validate n ~wrapped
|> Lib_name.to_string
Lib_name.Local.validate n ~wrapped
| None, Some { name = (loc, name) ; _ } ->
if dune_version >= (1, 1) then
match Lib_name.of_string name with
| Ok m -> Lib_name.to_string m
match Lib_name.to_local name with
| Ok m -> m
| Warn _ | Invalid ->
of_sexp_errorf loc
"%s.\n\
Public library names don't have this restriction. \
You can either change this public name to be a valid library \
name or add a \"name\" field with a valid library name."
Lib_name.invalid_message
Lib_name.Local.invalid_message
else
of_sexp_error loc "name field cannot be omitted before version \
1.1 of the dune language"
@ -1036,17 +965,19 @@ module Library = struct
| _ -> true
let stubs_archive t ~dir ~ext_lib =
Path.relative dir (sprintf "lib%s_stubs%s" t.name ext_lib)
Path.relative dir (sprintf "lib%s_stubs%s"
(Lib_name.Local.to_string t.name) ext_lib)
let dll t ~dir ~ext_dll =
Path.relative dir (sprintf "dll%s_stubs%s" t.name ext_dll)
Path.relative dir (sprintf "dll%s_stubs%s"
(Lib_name.Local.to_string t.name) ext_dll)
let archive t ~dir ~ext =
Path.relative dir (t.name ^ ext)
Path.relative dir (Lib_name.Local.to_string t.name ^ ext)
let best_name t =
match t.public with
| None -> t.name
| None -> Lib_name.of_local t.name
| Some p -> snd p.name
end

28
src/dune_file.mli
View File

@ -5,9 +5,11 @@ open Import
(** Ppx preprocessors *)
module Pp : sig
type t = private string
val of_string : string -> t
type t = private Lib_name.t
val of_string : loc:Loc.t option -> string -> t
val to_string : t -> string
val to_lib_name : t -> Lib_name.t
val compare : t -> t -> Ordering.t
end
@ -58,8 +60,8 @@ end
module Lib_dep : sig
type choice =
{ required : String.Set.t
; forbidden : String.Set.t
{ required : Lib_name.Set.t
; forbidden : Lib_name.Set.t
; file : string
}
@ -70,11 +72,11 @@ module Lib_dep : sig
}
type t =
| Direct of (Loc.t * string)
| Direct of (Loc.t * Lib_name.t)
| Select of select
val to_lib_names : t -> string list
val direct : Loc.t * string -> t
val to_lib_names : t -> Lib_name.t list
val direct : Loc.t * Lib_name.t -> t
val of_pp : Loc.t * Pp.t -> t
end
@ -146,13 +148,13 @@ end
module Public_lib : sig
type t =
{ name : Loc.t * string (** Full public name *)
{ name : Loc.t * Lib_name.t (** Full public name *)
; package : Package.t (** Package it is part of *)
; sub_dir : string option (** Subdirectory inside the installation
directory *)
}
val name : t -> string
val name : t -> Lib_name.t
end
module Sub_system_info : sig
@ -215,11 +217,11 @@ module Library : sig
end
type t =
{ name : string
{ name : Lib_name.Local.t
; public : Public_lib.t option
; synopsis : string option
; install_c_headers : string list
; ppx_runtime_libraries : (Loc.t * string) list
; ppx_runtime_libraries : (Loc.t * Lib_name.t) list
; modes : Mode_conf.Set.t
; kind : Kind.t
; c_flags : Ordered_set_lang.Unexpanded.t
@ -229,7 +231,7 @@ module Library : sig
; library_flags : Ordered_set_lang.Unexpanded.t
; c_library_flags : Ordered_set_lang.Unexpanded.t
; self_build_stubs_archive : string option
; virtual_deps : (Loc.t * string) list
; virtual_deps : (Loc.t * Lib_name.t) list
; wrapped : bool
; optional : bool
; buildable : Buildable.t
@ -244,7 +246,7 @@ module Library : sig
val stubs_archive : t -> dir:Path.t -> ext_lib:string -> Path.t
val dll : t -> dir:Path.t -> ext_dll:string -> Path.t
val archive : t -> dir:Path.t -> ext:string -> Path.t
val best_name : t -> string
val best_name : t -> Lib_name.t
end
module Install_conf : sig

72
src/findlib.ml
View File

@ -1,6 +1,8 @@
open! Stdune
open Import
module Opam_package = Package
module P = Variant
module Ps = Variant.Set
@ -122,7 +124,7 @@ module Config = struct
if not (Path.exists conf_file) then
die "@{<error>Error@}: ocamlfind toolchain %s isn't defined in %a \
(context: %s)" toolchain Path.pp path context;
let vars = (Meta.load ~name:"" conf_file).vars in
let vars = (Meta.load ~name:None conf_file).vars in
{ vars = String.Map.map vars ~f:Rules.of_meta_rules
; preds = Ps.make [toolchain]
}
@ -139,7 +141,7 @@ end
module Package = struct
type t =
{ meta_file : Path.t
; name : string
; name : Lib_name.t
; dir : Path.t
; vars : Vars.t
}
@ -160,8 +162,12 @@ module Package = struct
let version t = Vars.get t.vars "version" Ps.empty
let description t = Vars.get t.vars "description" Ps.empty
let jsoo_runtime t = get_paths t "jsoo_runtime" Ps.empty
let requires t = Vars.get_words t.vars "requires" preds
let ppx_runtime_deps t = Vars.get_words t.vars "ppx_runtime_deps" preds
let requires t =
Vars.get_words t.vars "requires" preds
|> List.map ~f:(Lib_name.of_string_exn ~loc:None)
let ppx_runtime_deps t =
Vars.get_words t.vars "ppx_runtime_deps" preds
|> List.map ~f:(Lib_name.of_string_exn ~loc:None)
let archives t = make_archives t "archive" preds
let plugins t =
@ -170,7 +176,8 @@ module Package = struct
(make_archives t "plugin" preds)
let dune_file t =
let fn = Path.relative t.dir (sprintf "%s.dune" t.name) in
let fn = Path.relative t.dir
(sprintf "%s.dune" (Lib_name.to_string t.name)) in
Option.some_if (Path.exists fn) fn
end
@ -191,22 +198,20 @@ end
type t =
{ stdlib_dir : Path.t
; path : Path.t list
; builtins : Meta.Simplified.t String.Map.t
; packages : (string, (Package.t, Unavailable_reason.t) result) Hashtbl.t
; builtins : Meta.Simplified.t Lib_name.Map.t
; packages : (Lib_name.t, (Package.t, Unavailable_reason.t) result) Hashtbl.t
}
let path t = t.path
let root_package_name s =
match String.index s '.' with
| None -> s
| Some i -> String.take s i
let dummy_package t ~name =
let dir =
match t.path with
| [] -> t.stdlib_dir
| dir :: _ -> Path.relative dir (root_package_name name)
| dir :: _ ->
Lib_name.package_name name
|> Opam_package.Name.to_string
|> Path.relative dir
in
{ Package.
meta_file = Path.relative dir "META"
@ -244,7 +249,7 @@ let parse_package t ~meta_file ~name ~parent_dir ~vars =
List.for_all exists_if ~f:(fun fn ->
Path.exists (Path.relative dir fn))
| [] ->
if not (String.Map.mem t.builtins (root_package_name name)) then
if not (Lib_name.Map.mem t.builtins (Lib_name.root_lib name)) then
true
else
(* The META files for installed packages are sometimes broken,
@ -277,34 +282,38 @@ let parse_and_acknowledge_meta t ~dir ~meta_file (meta : Meta.Simplified.t) =
in
Hashtbl.add t.packages full_name res;
List.iter meta.subs ~f:(fun (meta : Meta.Simplified.t) ->
loop ~dir ~full_name:(sprintf "%s.%s" full_name meta.name) meta)
let full_name =
match meta.name with
| None -> full_name
| Some name -> Lib_name.nest full_name name in
loop ~dir ~full_name meta)
in
loop ~dir ~full_name:meta.name meta
loop ~dir ~full_name:(Option.value_exn meta.name) meta
(* Search for a <package>/META file in the findlib search path, parse
it and add its contents to [t.packages] *)
let find_and_acknowledge_meta t ~fq_name =
let root_name = root_package_name fq_name in
let root_name = Lib_name.root_lib fq_name in
let rec loop dirs : (Path.t * Path.t * Meta.Simplified.t) option =
match dirs with
| dir :: dirs ->
let sub_dir = Path.relative dir root_name in
let sub_dir = Path.relative dir (Lib_name.to_string root_name) in
let fn = Path.relative sub_dir "META" in
if Path.exists fn then
Some (sub_dir,
fn,
Meta.load ~name:root_name fn)
Meta.load ~name:(Some root_name) fn)
else
(* Alternative layout *)
let fn = Path.relative dir ("META." ^ root_name) in
let fn = Path.relative dir ("META." ^ (Lib_name.to_string root_name)) in
if Path.exists fn then
Some (dir,
fn,
Meta.load fn ~name:root_name)
Meta.load fn ~name:(Some root_name))
else
loop dirs
| [] ->
String.Map.find t.builtins root_name
Lib_name.Map.find t.builtins root_name
|> Option.map ~f:(fun meta ->
(t.stdlib_dir, Path.of_string "<internal>", meta))
in
@ -336,15 +345,18 @@ let root_packages t =
List.concat_map t.path ~f:(fun dir ->
Sys.readdir (Path.to_string dir)
|> Array.to_list
|> List.filter ~f:(fun name ->
Path.exists (Path.relative dir (name ^ "/META"))))
|> String.Set.of_list
|> List.filter_map ~f:(fun name ->
if Path.exists (Path.relative dir (name ^ "/META")) then
Some (Lib_name.of_string_exn ~loc:None name)
else
None))
|> Lib_name.Set.of_list
in
String.Set.union pkgs
(String.Set.of_list (String.Map.keys t.builtins))
Lib_name.Set.union pkgs
(Lib_name.Set.of_list (Lib_name.Map.keys t.builtins))
let load_all_packages t =
String.Set.iter (root_packages t) ~f:(fun pkg ->
Lib_name.Set.iter (root_packages t) ~f:(fun pkg ->
find_and_acknowledge_meta t ~fq_name:pkg)
let all_packages t =
@ -353,7 +365,7 @@ let all_packages t =
match x with
| Ok p -> p :: acc
| Error _ -> acc)
|> List.sort ~compare:(fun (a : Package.t) b -> String.compare a.name b.name)
|> List.sort ~compare:(fun (a : Package.t) b -> Lib_name.compare a.name b.name)
let create ~stdlib_dir ~path =
{ stdlib_dir
@ -368,4 +380,4 @@ let all_unavailable_packages t =
match x with
| Ok _ -> acc
| Error e -> ((name, e) :: acc))
|> List.sort ~compare:(fun (a, _) (b, _) -> String.compare a b)
|> List.sort ~compare:(fun (a, _) (b, _) -> Lib_name.compare a b)

17
src/findlib.mli
View File

@ -14,23 +14,20 @@ val create
(** The search path for this DB *)
val path : t -> Path.t list
(** [root_package_name "foo.*"] is "foo" *)
val root_package_name : string -> string
module Package : sig
(** Representation of a findlib package *)
type t
val meta_file : t -> Path.t
val name : t -> string
val name : t -> Lib_name.t
val dir : t -> Path.t
val version : t -> string option
val description : t -> string option
val archives : t -> Path.t list Mode.Dict.t
val plugins : t -> Path.t list Mode.Dict.t
val jsoo_runtime : t -> Path.t list
val requires : t -> string list
val ppx_runtime_deps : t -> string list
val requires : t -> Lib_name.t list
val ppx_runtime_deps : t -> Lib_name.t list
val dune_file : t -> Path.t option
end
@ -46,18 +43,18 @@ module Unavailable_reason : sig
end
(** Lookup a package in the given database *)
val find : t -> string -> (Package.t, Unavailable_reason.t) result
val find : t -> Lib_name.t -> (Package.t, Unavailable_reason.t) result
val available : t -> string -> bool
val available : t -> Lib_name.t -> bool
(** List all the packages available in this Database *)
val all_packages : t -> Package.t list
(** List all the packages that are not available in this database *)
val all_unavailable_packages : t -> (string * Unavailable_reason.t) list
val all_unavailable_packages : t -> (Lib_name.t * Unavailable_reason.t) list
(** A dummy package. This is used to implement [external-lib-deps] *)
val dummy_package : t -> name:string -> Package.t
val dummy_package : t -> name:Lib_name.t -> Package.t
module Config : sig
type t

9
src/gen_meta.ml
View File

@ -8,6 +8,7 @@ module Pub_name = struct
| Id of string
let parse s =
let s = Lib_name.to_string s in
match String.split s ~on:'.' with
| [] -> assert false
| x :: l ->
@ -32,7 +33,9 @@ module Pub_name = struct
let to_string t = String.concat ~sep:"." (to_list t)
end
let string_of_deps deps = String.Set.to_list deps |> String.concat ~sep:" "
let string_of_deps deps =
Lib_name.Set.to_string_list deps
|> String.concat ~sep:" "
let rule var predicates action value =
Rule { var; predicates; action; value }
@ -82,7 +85,7 @@ let gen_lib pub_name lib ~version =
; requires ~preds lib_deps
]
; archives ~preds lib
; if String.Set.is_empty ppx_rt_deps then
; if Lib_name.Set.is_empty ppx_rt_deps then
[]
else
[ Comment "This is what dune uses to find out the runtime \
@ -163,7 +166,7 @@ let gen ~package ~version libs =
entries = directory name :: pkg.entries
})
in
{ name
{ name = Some (Lib_name.of_string_exn ~loc:None name)
; entries = entries @ subs
}
in

30
src/inline_tests.ml
View File

@ -13,10 +13,10 @@ module Backend = struct
type t =
{ loc : Loc.t
; runner_libraries : (Loc.t * string) list
; runner_libraries : (Loc.t * Lib_name.t) list
; flags : Ordered_set_lang.Unexpanded.t
; generate_runner : (Loc.t * Action.Unexpanded.t) option
; extends : (Loc.t * string) list
; extends : (Loc.t * Lib_name.t) list
}
type Dune_file.Sub_system_info.t += T of t
@ -36,10 +36,10 @@ module Backend = struct
let parse =
record
(let%map loc = loc
and runner_libraries = field "runner_libraries" (list (located string)) ~default:[]
and runner_libraries = field "runner_libraries" (list (located Lib_name.dparse)) ~default:[]
and flags = Ordered_set_lang.Unexpanded.field "flags"
and generate_runner = field_o "generate_runner" (located Action.Unexpanded.dparse)
and extends = field "extends" (list (located string)) ~default:[]
and extends = field "extends" (list (located Lib_name.dparse)) ~default:[]
in
{ loc
; runner_libraries
@ -75,15 +75,16 @@ module Backend = struct
resolve x >>= fun lib ->
match get ~loc lib with
| None ->
Error (Errors.exnf loc "%S is not an %s" name
Error (Errors.exnf loc "%S is not an %s"
(Lib_name.to_string name)
(desc ~plural:false))
| Some t -> Ok t))
}
let dgen t =
let open Dsexp.To_sexp in
let lib x = string (Lib.name x) in
let f x = string (Lib.name x.lib) in
let lib x = Lib_name.dgen (Lib.name x) in
let f x = Lib_name.dgen (Lib.name x.lib) in
((1, 0),
record_fields
[ field "runner_libraries" (list lib)
@ -109,8 +110,8 @@ include Sub_system.Register_end_point(
{ loc : Loc.t
; deps : Dep_conf.t list
; flags : Ordered_set_lang.Unexpanded.t
; backend : (Loc.t * string) option
; libraries : (Loc.t * string) list
; backend : (Loc.t * Lib_name.t) option
; libraries : (Loc.t * Lib_name.t) list
}
type Dune_file.Sub_system_info.t += T of t
@ -138,8 +139,8 @@ include Sub_system.Register_end_point(
(let%map loc = loc
and deps = field "deps" (list Dep_conf.dparse) ~default:[]
and flags = Ordered_set_lang.Unexpanded.field "flags"
and backend = field_o "backend" (located string)
and libraries = field "libraries" (list (located string)) ~default:[]
and backend = field_o "backend" (located Lib_name.dparse)
and libraries = field "libraries" (list (located Lib_name.dparse)) ~default:[]
in
{ loc
; deps
@ -161,7 +162,8 @@ include Sub_system.Register_end_point(
in
let inline_test_dir =
Path.relative dir (sprintf ".%s.inline-tests" lib.name)
Path.relative dir (sprintf ".%s.inline-tests"
(Lib_name.Local.to_string lib.name))
in
let name = "run" in
@ -178,7 +180,7 @@ include Sub_system.Register_end_point(
let bindings =
Pform.Map.singleton "library-name"
(Values [String lib.name])
(Values [String (Lib_name.Local.to_string lib.name)])
in
let runner_libs =
@ -186,7 +188,7 @@ include Sub_system.Register_end_point(
Result.List.concat_map backends
~f:(fun (backend : Backend.t) -> backend.runner_libraries)
>>= fun libs ->
Lib.DB.find_many (Scope.libs scope) [lib.name]
Lib.DB.find_many (Scope.libs scope) [Dune_file.Library.best_name lib]
>>= fun lib ->
Result.List.all
(List.map info.libraries

11
src/install_rules.ml
View File

@ -16,7 +16,7 @@ module Gen(P : Params) = struct
let ctx = Super_context.context sctx
let lib_dune_file ~dir ~name =
Path.relative dir (name ^ ".dune")
Path.relative dir ((Lib_name.to_string name) ^ ".dune")
let gen_lib_dune_file lib =
SC.add_rule sctx
@ -115,7 +115,7 @@ module Gen(P : Params) = struct
>>>
Build.write_file_dyn meta)))
let lib_install_files ~dir_contents ~dir ~sub_dir ~name ~scope ~dir_kind
let lib_install_files ~dir_contents ~dir ~sub_dir ~(name : Lib_name.t) ~scope ~dir_kind
(lib : Library.t) =
let obj_dir = Utils.library_object_directory ~dir lib.name in
let make_entry section ?dst fn =
@ -195,13 +195,16 @@ module Gen(P : Params) = struct
List.concat_map lib.buildable.libraries ~f:Lib_dep.to_lib_names
in
match
List.filter deps ~f:(function
List.filter deps ~f:(fun lib_name ->
match Lib_name.to_string lib_name with
| "ppx_driver" | "ppxlib" | "ppx_type_conv" -> true
| _ -> false)
with
| [] -> None
| l ->
match Scope.name scope, List.mem ~set:l "ppxlib" with
match Scope.name scope
, List.mem ~set:l (Lib_name.of_string_exn ~loc:None "ppxlib")
with
| Named "ppxlib", _ | _, true ->
Some "ppxlib.runner"
| _ ->

17
src/js_of_ocaml_rules.ml
View File

@ -20,11 +20,11 @@ let in_build_dir ~ctx =
let init = Path.relative ctx.Context.build_dir ".js" in
List.fold_left ~init ~f:Path.relative
let runtime_file ~sctx fname =
let runtime_file ~sctx file =
match
Artifacts.file_of_lib (SC.artifacts sctx)
~loc:Loc.none
~lib:"js_of_ocaml-compiler" ~file:fname
~lib:(Lib_name.of_string_exn ~loc:None "js_of_ocaml-compiler") ~file
with
| Error _ ->
Arg_spec.Dyn (fun _ ->
@ -89,7 +89,10 @@ let link_rule cc ~runtime ~target =
) else (
let lib_name = Lib.name lib in
List.map ~f:(fun js ->
in_build_dir ~ctx [lib_name ; Path.basename js]) jsoo_archives
in_build_dir ~ctx
[ Lib_name.to_string lib_name
; Path.basename js
]) jsoo_archives
)
)
in
@ -138,6 +141,7 @@ let setup_separate_compilation_rules sctx components =
match components with
| [] | _ :: _ :: _ -> ()
| [pkg] ->
let pkg = Lib_name.of_string_exn ~loc:None pkg in
let ctx = SC.context sctx in
match Lib.DB.find (SC.installed_libs sctx) pkg with
| Error _ -> ()
@ -146,17 +150,18 @@ let setup_separate_compilation_rules sctx components =
let archives =
(* Special case for the stdlib because it is not referenced
in the META *)
match Lib.name pkg with
match Lib_name.to_string (Lib.name pkg) with
| "stdlib" -> Path.relative ctx.stdlib_dir "stdlib.cma" :: archives
| _ -> archives
in
List.iter archives ~f:(fun fn ->
let name = Path.basename fn in
let src = Path.relative (Lib.src_dir pkg) name in
let lib_name = Lib_name.to_string (Lib.name pkg) in
let target =
in_build_dir ~ctx [ Lib.name pkg; sprintf "%s.js" name]
in_build_dir ~ctx [lib_name ; sprintf "%s.js" name]
in
let dir = in_build_dir ~ctx [ Lib.name pkg ] in
let dir = in_build_dir ~ctx [lib_name] in
let spec = Arg_spec.Dep src in
SC.add_rule sctx
(Build.return (standard sctx)

138
src/lib.ml
View File

@ -28,7 +28,7 @@ end
module Info = struct
module Deps = struct
type t =
| Simple of (Loc.t * string) list
| Simple of (Loc.t * Lib_name.t) list
| Complex of Dune_file.Lib_dep.t list
let of_lib_deps deps =
@ -60,10 +60,10 @@ module Info = struct
; foreign_archives : Path.t list Mode.Dict.t
; jsoo_runtime : Path.t list
; requires : Deps.t
; ppx_runtime_deps : (Loc.t * string) list
; ppx_runtime_deps : (Loc.t * Lib_name.t) list
; pps : (Loc.t * Dune_file.Pp.t) list
; optional : bool
; virtual_deps : (Loc.t * string) list
; virtual_deps : (Loc.t * Lib_name.t) list
; dune_version : Syntax.Version.t option
; sub_systems : Dune_file.Sub_system_info.t Sub_system_name.Map.t
}
@ -74,7 +74,8 @@ module Info = struct
~f:(fun acc s -> Dune_file.Lib_dep.Direct s :: acc)
let of_library_stanza ~dir ~ext_lib (conf : Dune_file.Library.t) =
let archive_file ext = Path.relative dir (conf.name ^ ext) in
let archive_file ext =
Path.relative dir (Lib_name.Local.to_string conf.name ^ ext) in
let archive_files ~f_ext =
Mode.Dict.of_func (fun ~mode -> [archive_file (f_ext mode)])
in
@ -96,7 +97,9 @@ module Info = struct
in
{ Mode.Dict.
byte = stubs
; native = Path.relative dir (conf.name ^ ext_lib) :: stubs
; native =
Path.relative dir (Lib_name.Local.to_string conf.name ^ ext_lib)
:: stubs
}
in
{ loc = conf.buildable.loc
@ -159,7 +162,7 @@ module Error0 = struct
module Reason = struct
module Hidden = struct
type t =
{ name : string
{ name : Lib_name.t
; path : Path.t
; reason : string
}
@ -180,7 +183,7 @@ module Error0 = struct
type t =
{ loc : Loc.t
; name : string
; name : Lib_name.t
; reason : Reason.t
}
end
@ -217,13 +220,13 @@ module Id = struct
type t =
{ unique_id : int
; path : Path.t
; name : string
; name : Lib_name.t
}
end
type t =
{ info : Info.t
; name : string
; name : Lib_name.t
; unique_id : int
; requires : t list Or_exn.t
; ppx_runtime_deps : t list Or_exn.t
@ -241,9 +244,9 @@ type t =
and db =
{ parent : db option
; resolve : string -> resolve_result
; table : (string, status) Hashtbl.t
; all : string list Lazy.t
; resolve : Lib_name.t -> resolve_result
; table : (Lib_name.t, status) Hashtbl.t
; all : Lib_name.t list Lazy.t
}
and status =
@ -255,7 +258,7 @@ and status =
and error =
| Library_not_available of Error0.Library_not_available.t
| No_solution_found_for_select of Error0.No_solution_found_for_select.t
| Dependency_cycle of (Path.t * string) list
| Dependency_cycle of (Path.t * Lib_name.t) list
| Conflict of conflict
| Overlap of overlap
| Private_deps_not_allowed of private_deps_not_allowed
@ -264,7 +267,7 @@ and resolve_result =
| Not_found
| Found of Info.t
| Hidden of Info.t * string
| Redirect of db option * string
| Redirect of db option * Lib_name.t
and conflict =
{ lib1 : t * Dep_path.Entry.t list
@ -310,7 +313,7 @@ module Error = struct
type t = error =
| Library_not_available of Library_not_available.t
| No_solution_found_for_select of No_solution_found_for_select.t
| Dependency_cycle of (Path.t * string) list
| Dependency_cycle of (Path.t * Lib_name.t) list
| Conflict of Conflict.t
| Overlap of Overlap.t
| Private_deps_not_allowed of Private_deps_not_allowed.t
@ -347,9 +350,7 @@ let status t = t.info.status
let package t =
match t.info.status with
| Installed ->
Some (Findlib.root_package_name t.name
|> Package.Name.of_string)
| Installed -> Some (Lib_name.package_name t.name)
| Public p -> Some p.name
| Private _ ->
None
@ -451,7 +452,7 @@ module Sub_system = struct
type t
type sub_system += T of t
val instantiate
: resolve:(Loc.t * string -> lib Or_exn.t)
: resolve:(Loc.t * Lib_name.t -> lib Or_exn.t)
-> get:(loc:Loc.t -> lib -> t option)
-> lib
-> Info.t
@ -492,7 +493,8 @@ module Sub_system = struct
| M.Info.T info ->
let get ~loc lib' =
if lib.unique_id = lib'.unique_id then
Errors.fail loc "Library %S depends on itself" lib.name
Errors.fail loc "Library %a depends on itself"
Lib_name.pp_quoted lib.name
else
M.get lib'
in
@ -583,7 +585,7 @@ let check_private_deps lib ~loc ~allow_private_deps =
Ok lib
let already_in_table (info : Info.t) name x =
let dgen = Sexp.To_sexp.(pair Path.to_sexp string) in
let to_sexp = Sexp.To_sexp.(pair Path.to_sexp Lib_name.to_sexp) in
let sexp =
match x with
| St_initializing x ->
@ -600,8 +602,8 @@ let already_in_table (info : Info.t) name x =
in
Exn.code_error
"Lib_db.DB: resolver returned name that's already in the table"
[ "name" , Sexp.To_sexp.string name
; "returned_lib" , dgen (info.src_dir, name)
[ "name" , Lib_name.to_sexp name
; "returned_lib" , to_sexp (info.src_dir, name)
; "conflicting_with", sexp
]
@ -635,7 +637,7 @@ let rec instantiate db name (info : Info.t) ~stack ~hidden =
let requires = map_error requires in
let ppx_runtime_deps = map_error ppx_runtime_deps in
let resolve (loc, name) =
resolve_dep db name ~allow_private_deps ~loc ~stack in
resolve_dep db (name : Lib_name.t) ~allow_private_deps ~loc ~stack in
let t =
{ info
; name
@ -680,12 +682,12 @@ and find_even_when_hidden db name =
| St_not_found -> None
| St_hidden (t, _) -> Some t
and find_internal db name ~stack : status =
and find_internal db (name : Lib_name.t) ~stack : status =
match Hashtbl.find db.table name with
| Some x -> x
| None -> resolve_name db name ~stack
and resolve_dep db name ~allow_private_deps ~loc ~stack : t Or_exn.t =
and resolve_dep db (name : Lib_name.t) ~allow_private_deps ~loc ~stack : t Or_exn.t =
match find_internal db name ~stack with
| St_initializing id ->
Error (Dep_stack.dependency_cycle stack id)
@ -727,12 +729,12 @@ and resolve_name db name ~stack =
| _ ->
instantiate db name info ~stack ~hidden:(Some hidden)
and available_internal db name ~stack =
and available_internal db (name : Lib_name.t) ~stack =
match resolve_dep db name ~allow_private_deps:true ~loc:Loc.none ~stack with
| Ok _ -> true
| Error _ -> false
and resolve_simple_deps db names ~allow_private_deps ~stack =
and resolve_simple_deps db (names : ((Loc.t * Lib_name.t) list)) ~allow_private_deps ~stack =
Result.List.map names ~f:(fun (loc, name) ->
resolve_dep db name ~allow_private_deps ~loc ~stack)
@ -750,13 +752,13 @@ and resolve_complex_deps db deps ~allow_private_deps ~stack =
let res, src_fn =
match
List.find_map choices ~f:(fun { required; forbidden; file } ->
if String.Set.exists forbidden
if Lib_name.Set.exists forbidden
~f:(available_internal db ~stack) then
None
else
match
let deps =
String.Set.fold required ~init:[] ~f:(fun x acc ->
Lib_name.Set.fold required ~init:[] ~f:(fun x acc ->
(Loc.none, x) :: acc)
in
resolve_simple_deps ~allow_private_deps db deps ~stack
@ -808,7 +810,7 @@ and resolve_user_deps db deps ~allow_private_deps ~pps ~stack =
{ (fst first) with stop = (fst last).stop }
in
let pps =
let pps = (pps : (Loc.t * Dune_file.Pp.t) list :> (Loc.t * string) list) in
let pps = (pps : (Loc.t * Dune_file.Pp.t) list :> (Loc.t * Lib_name.t) list) in
resolve_simple_deps db pps ~allow_private_deps:true ~stack
>>= fun pps ->
closure_with_overlap_checks None pps ~stack
@ -834,11 +836,11 @@ and resolve_user_deps db deps ~allow_private_deps ~pps ~stack =
(deps, pps, resolved_selects)
and closure_with_overlap_checks db ts ~stack =
let visited = ref String.Map.empty in
let visited = ref Lib_name.Map.empty in
let res = ref [] in
let orig_stack = stack in
let rec loop t ~stack =
match String.Map.find !visited t.name with
match Lib_name.Map.find !visited t.name with
| Some (t', stack') ->
if t.unique_id = t'.unique_id then
Ok ()
@ -849,7 +851,7 @@ and resolve_user_deps db deps ~allow_private_deps ~pps ~stack =
; lib2 = (t , req_by stack )
}))
| None ->
visited := String.Map.add !visited t.name (t, stack);
visited := Lib_name.Map.add !visited t.name (t, stack);
(match db with
| None -> Ok ()
| Some db ->
@ -934,7 +936,7 @@ module DB = struct
| Not_found
| Found of Info.t
| Hidden of Info.t * string
| Redirect of db option * string
| Redirect of db option * Lib_name.t
end
type t = db
@ -952,22 +954,22 @@ module DB = struct
let info = Info.of_library_stanza ~dir ~ext_lib conf in
match conf.public with
| None ->
[(conf.name, Resolve_result.Found info)]
[Dune_file.Library.best_name conf, Resolve_result.Found info]
| Some p ->
let name = Dune_file.Public_lib.name p in
if name = conf.name then
[(name, Found info)]
if name = Lib_name.of_local conf.name then
[name, Found info]
else
[ name , Found info
; conf.name, Redirect (None, name)
[ name , Found info
; Lib_name.of_local conf.name, Redirect (None, name)
])
|> String.Map.of_list
|> Lib_name.Map.of_list
|> function
| Ok x -> x
| Error (name, _, _) ->
match
List.filter_map stanzas ~f:(fun (_, (conf : Dune_file.Library.t)) ->
if name = conf.name ||
if name = Lib_name.of_local conf.name ||
match conf.public with
| None -> false
| Some p -> name = Dune_file.Public_lib.name p
@ -976,19 +978,19 @@ module DB = struct
with
| [] | [_] -> assert false
| loc1 :: loc2 :: _ ->
die "Library %S is defined twice:\n\
die "Library %a is defined twice:\n\
- %s\n\
- %s"
name
Lib_name.pp_quoted name
(Loc.to_file_colon_line loc1)
(Loc.to_file_colon_line loc2)
in
create () ?parent
~resolve:(fun name ->
match String.Map.find map name with
match Lib_name.Map.find map name with
| None -> Not_found
| Some x -> x)
~all:(fun () -> String.Map.keys map)
~all:(fun () -> Lib_name.Map.keys map)
let create_from_findlib ?(external_lib_deps_mode=false) findlib =
create ()
@ -1033,7 +1035,7 @@ module DB = struct
match find_even_when_hidden t name with
| None ->
Exn.code_error "Lib.DB.get_compile_info got library that doesn't exist"
[ "name", Sexp.To_sexp.string name ]
[ "name", Lib_name.to_sexp name ]
| Some lib ->
let t = Option.some_if (not allow_overlaps) t in
Compile.for_lib t lib
@ -1060,7 +1062,7 @@ module DB = struct
let resolve_pps t pps =
resolve_simple_deps t ~allow_private_deps:true
(pps : (Loc.t * Dune_file.Pp.t) list :> (Loc.t * string) list)
(pps : (Loc.t * Dune_file.Pp.t) list :> (Loc.t * Lib_name.t) list)
~stack:Dep_stack.empty
let rec all ?(recursive=false) t =
@ -1081,8 +1083,8 @@ end
module Meta = struct
let to_names ts =
List.fold_left ts ~init:String.Set.empty ~f:(fun acc t ->
String.Set.add acc t.name)
List.fold_left ts ~init:Lib_name.Set.empty ~f:(fun acc t ->
Lib_name.Set.add acc t.name)
(* For the deprecated method, we need to put all the runtime
dependencies of the transitive closure.
@ -1110,30 +1112,34 @@ let report_lib_error ppf (e : Error.t) =
match e with
| Library_not_available { loc = _; name; reason } ->
Format.fprintf ppf
"@{<error>Error@}: Library %S %a.@\n"
name
"@{<error>Error@}: Library %a %a.@\n"
Lib_name.pp_quoted name
Error.Library_not_available.Reason.pp reason
| Conflict { lib1 = (lib1, rb1); lib2 = (lib2, rb2) } ->
Format.fprintf ppf
"@[<v>@{<error>Error@}: Conflict between the following libraries:@,\
- %S in %s@,\
- %a in %s@,\
\ %a@,\
- %S in %s@,\
- %a in %s@,\
\ %a@,\
This cannot work.@\n"
lib1.name (Path.to_string_maybe_quoted lib1.info.src_dir)
Lib_name.pp_quoted lib1.name
(Path.to_string_maybe_quoted lib1.info.src_dir)
Dep_path.Entries.pp rb1
lib2.name (Path.to_string_maybe_quoted lib2.info.src_dir)
Lib_name.pp_quoted lib2.name
(Path.to_string_maybe_quoted lib2.info.src_dir)
Dep_path.Entries.pp rb2
| Overlap { in_workspace = lib1; installed = (lib2, rb2) } ->
Format.fprintf ppf
"@[<v>@{<error>Error@}: Conflict between the following libraries:@,\
- %S in %s@,\
- %S in %s@,\
- %a in %s@,\
- %a in %s@,\
\ %a@,\
This is not allowed.@\n"
lib1.name (Path.to_string_maybe_quoted lib1.info.src_dir)
lib2.name (Path.to_string_maybe_quoted lib2.info.src_dir)
Lib_name.pp_quoted lib1.name
(Path.to_string_maybe_quoted lib1.info.src_dir)
Lib_name.pp_quoted lib2.name
(Path.to_string_maybe_quoted lib2.info.src_dir)
Dep_path.Entries.pp rb2
| No_solution_found_for_select { loc } ->
Format.fprintf ppf
@ -1145,15 +1151,15 @@ let report_lib_error ppf (e : Error.t) =
following libraries:@\n\
@[<v>%a@]\n"
(Format.pp_print_list (fun ppf (path, name) ->
Format.fprintf ppf "-> %S in %s"
name (Path.to_string_maybe_quoted path)))
Format.fprintf ppf "-> %a in %s"
Lib_name.pp_quoted name (Path.to_string_maybe_quoted path)))
cycle
| Private_deps_not_allowed t ->
Format.fprintf ppf
"@{<error>Error@}: Library %S is private, it cannot be a dependency of \
a public library.\nYou need to give %S a public name.\n"
t.private_dep.name
t.private_dep.name
"@{<error>Error@}: Library %a is private, it cannot be a dependency of \
a public library.\nYou need to give %a a public name.\n"
Lib_name.pp_quoted t.private_dep.name
Lib_name.pp_quoted t.private_dep.name
let () =
Report_error.register (fun exn ->

40
src/lib.mli
View File

@ -8,7 +8,7 @@ type t
(** For libraries defined in the workspace, this is the [public_name] if
present or the [name] if not. *)
val name : t -> string
val name : t -> Lib_name.t
(* CR-someday diml: this should be [Path.t list], since some libraries
have multiple source directories because of [copy_files]. *)
@ -83,7 +83,7 @@ end
module Info : sig
module Deps : sig
type t =
| Simple of (Loc.t * string) list
| Simple of (Loc.t * Lib_name.t) list
| Complex of Dune_file.Lib_dep.t list
end
@ -102,10 +102,10 @@ module Info : sig
; foreign_archives : Path.t list Mode.Dict.t (** [.a/.lib/...] files *)
; jsoo_runtime : Path.t list
; requires : Deps.t
; ppx_runtime_deps : (Loc.t * string) list
; ppx_runtime_deps : (Loc.t * Lib_name.t) list
; pps : (Loc.t * Dune_file.Pp.t) list
; optional : bool
; virtual_deps : (Loc.t * string) list
; virtual_deps : (Loc.t * Lib_name.t) list
; dune_version : Syntax.Version.t option
; sub_systems : Dune_file.Sub_system_info.t Sub_system_name.Map.t
}
@ -126,7 +126,7 @@ module Error : sig
module Reason : sig
module Hidden : sig
type t =
{ name : string
{ name : Lib_name.t
; path : Path.t
; reason : string
}
@ -142,7 +142,7 @@ module Error : sig
type nonrec t =
{ loc : Loc.t (** For names coming from Jbuild files *)
; name : string
; name : Lib_name.t
; reason : Reason.t
}
end
@ -178,7 +178,7 @@ module Error : sig
type t =
| Library_not_available of Library_not_available.t
| No_solution_found_for_select of No_solution_found_for_select.t
| Dependency_cycle of (Path.t * string) list
| Dependency_cycle of (Path.t * Lib_name.t) list
| Conflict of Conflict.t
| Overlap of Overlap.t
| Private_deps_not_allowed of Private_deps_not_allowed.t
@ -242,7 +242,7 @@ module DB : sig
| Not_found
| Found of Info.t
| Hidden of Info.t * string
| Redirect of t option * string
| Redirect of t option * Lib_name.t
end
(** Create a new library database. [resolve] is used to resolve
@ -255,8 +255,8 @@ module DB : sig
*)
val create
: ?parent:t
-> resolve:(string -> Resolve_result.t)
-> all:(unit -> string list)
-> resolve:(Lib_name.t -> Resolve_result.t)
-> all:(unit -> Lib_name.t list)
-> unit
-> t
@ -272,21 +272,21 @@ module DB : sig
-> Findlib.t
-> t
val find : t -> string -> (lib, Error.Library_not_available.Reason.t) result
val find : t -> Lib_name.t -> (lib, Error.Library_not_available.Reason.t) result
val find_many
: t
-> string list
-> Lib_name.t list
-> lib list Or_exn.t
val find_even_when_hidden : t -> string -> lib option
val find_even_when_hidden : t -> Lib_name.t -> lib option
val available : t -> string -> bool
val available : t -> Lib_name.t -> bool
(** Retrieve the compile information for the given library. Works
for libraries that are optional and not available as well. *)
val get_compile_info : t -> ?allow_overlaps:bool -> string -> Compile.t
val get_compile_info : t -> ?allow_overlaps:bool -> Lib_name.t -> Compile.t
val resolve : t -> Loc.t * string -> lib Or_exn.t
val resolve : t -> Loc.t * Lib_name.t -> lib Or_exn.t
(** Resolve libraries written by the user in a jbuild file. The
resulting list of libraries is transitively closed and sorted by
@ -327,7 +327,7 @@ module Sub_system : sig
type t
type sub_system += T of t
val instantiate
: resolve:(Loc.t * string -> lib Or_exn.t)
: resolve:(Loc.t * Lib_name.t -> lib Or_exn.t)
-> get:(loc:Loc.t -> lib -> t option)
-> lib
-> Info.t
@ -346,7 +346,7 @@ end with type lib := t
(** {1 Dependencies for META files} *)
module Meta : sig
val requires : t -> String.Set.t
val ppx_runtime_deps : t -> String.Set.t
val ppx_runtime_deps_for_deprecated_method : t -> String.Set.t
val requires : t -> Lib_name.Set.t
val ppx_runtime_deps : t -> Lib_name.Set.t
val ppx_runtime_deps_for_deprecated_method : t -> Lib_name.Set.t
end

4
src/lib_deps_info.ml
View File

@ -11,10 +11,10 @@ module Kind = struct
| _ -> Required
end
type t = Kind.t String.Map.t
type t = Kind.t Lib_name.Map.t
let merge a b =
String.Map.merge a b ~f:(fun _ a b ->
Lib_name.Map.merge a b ~f:(fun _ a b ->
match a, b with
| None, None -> None
| x, None | None, x -> x

2
src/lib_deps_info.mli
View File

@ -13,6 +13,6 @@ module Kind : sig
val merge : t -> t -> t
end
type t = Kind.t String.Map.t
type t = Kind.t Lib_name.Map.t
val merge : t -> t -> t

124
src/lib_name.ml Normal file
View File

@ -0,0 +1,124 @@
open Stdune
exception Invalid_lib_name of string
let dgen = Dsexp.To_sexp.string
let dparse = Dsexp.Of_sexp.string
module Local = struct
type t = string
type result =
| Ok of t
| Warn of t
| Invalid
let valid_char = function
| 'A'..'Z' | 'a'..'z' | '_' | '0'..'9' -> true
| _ -> false
let of_string (name : string) =
match name with
| "" -> Invalid
| (s : string) ->
if s.[0] = '.' then
Invalid
else
let len = String.length s in
let rec loop warn i =
if i = len - 1 then
if warn then Warn s else Ok s
else
let c = String.unsafe_get s i in
if valid_char c then
loop warn (i + 1)
else if c = '.' then
loop true (i + 1)
else
Invalid
in
loop false 0
let of_string_exn s =
match of_string s with
| Ok s -> s
| Warn _
| Invalid -> raise (Invalid_lib_name s)
let dparse_loc =
Dsexp.Of_sexp.plain_string (fun ~loc s -> (loc, of_string s))
let dgen = Dsexp.To_sexp.string
let to_sexp = Sexp.To_sexp.string
let pp_quoted fmt t = Format.fprintf fmt "%S" t
let invalid_message =
"invalid library name.\n\
Hint: library names must be non-empty and composed only of \
the following characters: 'A'..'Z', 'a'..'z', '_' or '0'..'9'"
let wrapped_message =
sprintf
"%s.\n\
This is temporary allowed for libraries with (wrapped false).\
\nIt will not be supported in the future. \
Please choose a valid name field."
invalid_message
let validate (loc, res) ~wrapped =
match res, wrapped with
| Ok s, _ -> s
| Warn _, true -> Errors.fail loc "%s" wrapped_message
| Warn s, false -> Errors.warn loc "%s" wrapped_message; s
| Invalid, _ -> Errors.fail loc "%s" invalid_message
let to_string s = s
end
let split t =
match String.split t ~on:'.' with
| [] -> assert false
| pkg :: rest -> (Package.Name.of_string pkg, rest)
let pp = Format.pp_print_string
let pp_quoted fmt t = Format.fprintf fmt "%S" t
let compare = String.compare
let to_local = Local.of_string
let to_sexp t = Sexp.Atom t
let to_string t = t
let of_string_exn ~loc:_ s = s
let of_local t = t
type t = string
module Map = Map.Make(String)
module Set = struct
include Set.Make(String)
let to_string_list = to_list
end
let root_lib t =
match String.lsplit2 t ~on:'.' with
| None -> t
| Some (p, _) -> p
let package_name t =
Package.Name.of_string (root_lib t)
let nest x y = sprintf "%s.%s" x y
module L = struct
let to_key = function
| [] -> "+none+"
| names -> String.concat ~sep:"+" names
end

63
src/lib_name.mli Normal file
View File

@ -0,0 +1,63 @@
open Stdune
type t
val of_string_exn : loc:Loc.t option -> string -> t
val to_string : t -> string
include Dsexp.Sexpable with type t := t
module Local : sig
type t
type result =
| Ok of t
| Warn of t
| Invalid
val dgen : t Dsexp.To_sexp.t
val dparse_loc : (Loc.t * result) Dsexp.Of_sexp.t
val validate : (Loc.t * result) -> wrapped:bool -> t
val to_sexp : t Sexp.To_sexp.t
val of_string_exn : string -> t
val of_string : string -> result
val to_string : t -> string
val invalid_message : string
val pp_quoted : t Fmt.t
end
val compare : t -> t -> Ordering.t
val pp : t Fmt.t
val pp_quoted : t Fmt.t
val of_local : Local.t -> t
val to_local : t -> Local.result
val split : t -> Package.Name.t * string list
val package_name : t -> Package.Name.t
val root_lib : t -> t
module Map : Map.S with type key = t
module Set : sig
include Set.S with type elt = t
val to_string_list : t -> string list
end
val to_sexp : t Sexp.To_sexp.t
val nest : t -> t -> t
module L : sig
val to_key : t list -> string
end

7
src/lib_rules.ml
View File

@ -35,7 +35,7 @@ module Gen (P : Install_rules.Params) = struct
if not (Library.has_stubs lib) then
[]
else
let stubs_name = lib.name ^ "_stubs" in
let stubs_name = Lib_name.Local.to_string lib.name ^ "_stubs" in
match mode with
| Byte -> ["-dllib"; "-l" ^ stubs_name; "-cclib"; "-l" ^ stubs_name]
| Native -> ["-cclib"; "-l" ^ stubs_name]
@ -175,7 +175,8 @@ module Gen (P : Install_rules.Params) = struct
[ As (Utils.g ())
; if custom then A "-custom" else As []
; A "-o"
; Path (Path.relative dir (sprintf "%s_stubs" lib.name))
; Path (Path.relative dir (sprintf "%s_stubs"
(Lib_name.Local.to_string lib.name)))
; Deps o_files
; Dyn (fun cclibs ->
(* https://github.com/ocaml/dune/issues/119 *)
@ -421,7 +422,7 @@ module Gen (P : Install_rules.Params) = struct
let rules (lib : Library.t) ~dir_contents ~dir ~scope
~dir_kind : Compilation_context.t * Merlin.t =
let compile_info =
Lib.DB.get_compile_info (Scope.libs scope) lib.name
Lib.DB.get_compile_info (Scope.libs scope) (Library.best_name lib)
~allow_overlaps:lib.buildable.allow_overlapping_dependencies
in
SC.Libs.gen_select_rules sctx compile_info ~dir;

4
src/main.ml
View File

@ -133,8 +133,8 @@ let external_lib_deps ?log ~packages () =
Path.Map.map
(Build_system.all_lib_deps setup.build_system
~request:(Build.paths install_files))
~f:(String.Map.filteri ~f:(fun name _ ->
not (String.Set.mem internals name))))
~f:(Lib_name.Map.filteri ~f:(fun name _ ->
not (Lib_name.Set.mem internals name))))
let ignored_during_bootstrap =
Path.Set.of_list

2
src/merlin.ml
View File

@ -70,7 +70,7 @@ type t =
{ requires : Lib.Set.t
; flags : (unit, string list) Build.t
; preprocess : Preprocess.t
; libname : string option
; libname : Lib_name.Local.t option
; source_dirs: Path.Set.t
; objs_dirs : Path.Set.t
}

2
src/merlin.mli
View File

@ -9,7 +9,7 @@ val make
: ?requires:Lib.t list Or_exn.t
-> ?flags:(unit, string list) Build.t
-> ?preprocess:Dune_file.Preprocess.t
-> ?libname:string
-> ?libname:Lib_name.Local.t
-> ?source_dirs: Path.Set.t
-> ?objs_dirs:Path.Set.t
-> unit

37
src/meta.ml
View File

@ -2,7 +2,7 @@ open! Stdune
open Import
type t =
{ name : string
{ name : Lib_name.t option
; entries : entry list
}
@ -34,7 +34,7 @@ module Parse = struct
| String s ->
if String.contains s '.' then
error lb "'.' not allowed in sub-package names";
s
Lib_name.of_string_exn ~loc:None s
| _ -> error lb "package name expected"
let string lb =
@ -88,7 +88,8 @@ module Parse = struct
let name = package_name lb in
lparen lb;
let sub_entries = entries lb (depth + 1) [] in
entries lb depth (Package { name; entries = sub_entries } :: acc)
entries lb depth (Package { name = Some name; entries = sub_entries }
:: acc)
| Name var ->
let predicates, action =
match next lb with
@ -134,14 +135,14 @@ module Simplified = struct
end
type t =
{ name : string
{ name : Lib_name.t option
; vars : Rules.t String.Map.t
; subs : t list
}
let rec pp fmt t =
Fmt.record fmt
[ "name", Fmt.const Fmt.quoted t.name
[ "name", Fmt.const (Fmt.optional Lib_name.pp_quoted) t.name
; "vars", Fmt.const (String.Map.pp Rules.pp) t.vars
; "subs", Fmt.const (Fmt.ocaml_list pp) t.subs
]
@ -196,9 +197,15 @@ let archives name =
let builtins ~stdlib_dir =
let version = version "[distributed with Ocaml]" in
let simple name ?dir ?(archive_name=name) deps =
let simple name ?dir ?archive_name deps =
let archive_name =
match archive_name with
| None -> name
| Some a -> a
in
let name = Lib_name.of_string_exn ~loc:None name in
let archives = archives archive_name in
{ name
{ name = Some name
; entries =
(requires deps ::
version ::
@ -211,7 +218,7 @@ let builtins ~stdlib_dir =
let sub name deps =
Package (simple name deps ~archive_name:("ocaml" ^ name))
in
{ name = "compiler-libs"
{ name = Some (Lib_name.of_string_exn ~loc:None "compiler-libs")
; entries =
[ requires []
; version
@ -227,7 +234,7 @@ let builtins ~stdlib_dir =
let unix = simple "unix" [] ~dir:"+" in
let bigarray = simple "bigarray" ["unix"] ~dir:"+" in
let threads =
{ name = "threads"
{ name = Some (Lib_name.of_string_exn ~loc:None "threads")
; entries =
[ version
; requires ~preds:[Pos "mt"; Pos "mt_vm" ] ["threads.vm"]
@ -242,7 +249,7 @@ let builtins ~stdlib_dir =
}
in
let num =
{ name = "num"
{ name = Some (Lib_name.of_string_exn ~loc:None "num")
; entries =
[ requires ["num.core"]
; version
@ -259,8 +266,9 @@ let builtins ~stdlib_dir =
else
[ compiler_libs; str; unix; bigarray; threads ]
in
List.map libs ~f:(fun t -> t.name, simplify t)
|> String.Map.of_list_exn
List.filter_map libs ~f:(fun t ->
Option.map t.name ~f:(fun name -> name, simplify t))
|> Lib_name.Map.of_list_exn
let string_of_action = function
| Set -> "="
@ -313,5 +321,10 @@ and pp_entry ppf entry =
var (String.concat ~sep:"," (List.map predicates ~f:string_of_predicate))
(string_of_action action) (pp_quoted_value var) value
| Package { name; entries } ->
let name =
match name with
| None -> ""
| Some l -> Lib_name.to_string l
in
fprintf ppf "@[<v 2>package %S (@,%a@]@,)"
name pp entries

8
src/meta.mli
View File

@ -4,7 +4,7 @@ open! Stdune
open! Import
type t =
{ name : string
{ name : Lib_name.t option
; entries : entry list
}
@ -35,7 +35,7 @@ module Simplified : sig
end
type t =
{ name : string
{ name : Lib_name.t option
; vars : Rules.t String.Map.t
; subs : t list
}
@ -43,10 +43,10 @@ module Simplified : sig
val pp : Format.formatter -> t -> unit
end
val load : Path.t -> name:string -> Simplified.t
val load : Path.t -> name:Lib_name.t option -> Simplified.t
(** Builtin META files for libraries distributed with the compiler. For when ocamlfind is
not installed. *)
val builtins : stdlib_dir:Path.t -> Simplified.t String.Map.t
val builtins : stdlib_dir:Path.t -> Simplified.t Lib_name.Map.t
val pp : Format.formatter -> entry list -> unit

3
src/module.ml
View File

@ -122,7 +122,8 @@ let iter t ~f =
Option.iter t.intf ~f:(f Ml_kind.Intf)
let with_wrapper t ~libname =
{ t with obj_name = sprintf "%s__%s" libname t.name }
{ t with obj_name
= sprintf "%s__%s" (Lib_name.Local.to_string libname) t.name }
let map_files t ~f =
{ t with

2
src/module.mli
View File

@ -87,7 +87,7 @@ val iter : t -> f:(Ml_kind.t -> File.t -> unit) -> unit
val has_impl : t -> bool
(** Prefix the object name with the library name. *)
val with_wrapper : t -> libname:string -> t
val with_wrapper : t -> libname:Lib_name.Local.t -> t
val map_files : t -> f:(Ml_kind.t -> File.t -> File.t) -> t

16
src/odoc.ml
View File

@ -11,8 +11,9 @@ let lib_unique_name lib =
let name = Lib.name lib in
match Lib.status lib with
| Installed -> assert false
| Public _ -> name
| Private scope_name -> SC.Scope_key.to_string name scope_name
| Public _ -> Lib_name.to_string name
| Private scope_name ->
SC.Scope_key.to_string (Lib_name.to_string name) scope_name
let pkg_or_lnu lib =
match Lib.package lib with
@ -196,7 +197,7 @@ module Gen (S : sig val sctx : SC.t end) = struct
~requires ~(dep_graphs:Ocamldep.Dep_graph.t Ml_kind.Dict.t) =
let lib =
Option.value_exn (Lib.DB.find_even_when_hidden (Scope.libs scope)
library.name) in
(Library.best_name library)) in
(* Using the proper package name doesn't actually work since odoc assumes
that a package contains only 1 library *)
let pkg_or_lnu = pkg_or_lnu lib in
@ -350,6 +351,7 @@ module Gen (S : sig val sctx : SC.t end) = struct
() (* rules were already setup lazily in gen_rules *)
| "_odoc" :: "lib" :: lib :: _ ->
let lib, lib_db = SC.Scope_key.of_string sctx lib in
let lib = Lib_name.of_string_exn ~loc:None lib in
begin match Lib.DB.find lib_db lib with
| Error _ -> ()
| Ok lib -> SC.load_dir sctx ~dir:(Lib.src_dir lib)
@ -358,6 +360,7 @@ module Gen (S : sig val sctx : SC.t end) = struct
(* TODO we can be a better with the error handling in the case where
lib_unique_name_or_pkg is neither a valid pkg or lnu *)
let lib, lib_db = SC.Scope_key.of_string sctx lib_unique_name_or_pkg in
let lib = Lib_name.of_string_exn ~loc:None lib in
let setup_pkg_html_rules pkg =
setup_pkg_html_rules ~pkg ~libs:(
Lib.Set.to_list (load_all_odoc_rules_pkg ~pkg)) in
@ -413,9 +416,9 @@ module Gen (S : sig val sctx : SC.t end) = struct
let b = Buffer.create 512 in
Lib.Map.to_list entry_modules
|> List.sort ~compare:(fun (x, _) (y, _) ->
String.compare (Lib.name x) (Lib.name y))
Lib_name.compare (Lib.name x) (Lib.name y))
|> List.iter ~f:(fun (lib, modules) ->
Printf.bprintf b "{2 Library %s}\n" (Lib.name lib);
Printf.bprintf b "{2 Library %s}\n" (Lib_name.to_string (Lib.name lib));
Buffer.add_string b (
match modules with
| [ x ] ->
@ -513,7 +516,8 @@ module Gen (S : sig val sctx : SC.t end) = struct
| None ->
let scope = SC.find_scope_by_dir sctx w.ctx_dir in
Some (Option.value_exn (
Lib.DB.find_even_when_hidden (Scope.libs scope) l.name)
Lib.DB.find_even_when_hidden (Scope.libs scope)
(Library.best_name l))
)
end
| _ -> None

40
src/preprocessing.ml
View File

@ -27,7 +27,7 @@ module Driver = struct
; as_ppx_flags : Ordered_set_lang.Unexpanded.t
; lint_flags : Ordered_set_lang.Unexpanded.t
; main : string
; replaces : (Loc.t * string) list
; replaces : (Loc.t * Lib_name.t) list
}
type Dune_file.Sub_system_info.t += T of t
@ -53,7 +53,8 @@ module Driver = struct
~check:(Syntax.since syntax (1, 1))
and lint_flags = Ordered_set_lang.Unexpanded.field "lint_flags"
and main = field "main" string
and replaces = field "replaces" (list (located string)) ~default:[]
and replaces =
field "replaces" (list (located (Lib_name.dparse))) ~default:[]
in
{ loc
; flags
@ -92,14 +93,15 @@ module Driver = struct
resolve x >>= fun lib ->
match get ~loc lib with
| None ->
Error (Errors.exnf loc "%S is not a %s" name
Error (Errors.exnf loc "%a is not a %s"
Lib_name.pp_quoted name
(desc ~plural:false))
| Some t -> Ok t))
}
let dgen t =
let open Dsexp.To_sexp in
let f x = string (Lib.name (Lazy.force x.lib)) in
let f x = Lib_name.dgen (Lib.name (Lazy.force x.lib)) in
((1, 0),
record
[ "flags" , Ordered_set_lang.Unexpanded.dgen
@ -139,7 +141,7 @@ module Driver = struct
| _ ->
match
List.filter_map libs ~f:(fun lib ->
match Lib.name lib with
match Lib_name.to_string (Lib.name lib) with
| "ocaml-migrate-parsetree" | "ppxlib" | "ppx_driver" as s ->
Some s
| _ -> None)
@ -171,7 +173,7 @@ module Driver = struct
(sprintf
"Too many incompatible ppx drivers were found: %s."
(String.enumerate_and (List.map ts ~f:(fun t ->
Lib.name (lib t)))))
Lib_name.to_string (Lib.name (lib t))))))
| Error (Other exn) ->
Error exn
end
@ -197,7 +199,7 @@ module Jbuild_driver = struct
~lexer:Dsexp.Lexer.jbuild_token
|> Dsexp.Of_sexp.parse Driver.Info.parse parsing_context
in
(Pp.of_string name,
(Pp.of_string ~loc:None name,
{ info
; lib = lazy (assert false)
; replaces = Ok []
@ -219,9 +221,9 @@ module Jbuild_driver = struct
|}
let drivers =
[ Pp.of_string "ocaml-migrate-parsetree.driver-main" , omp
; Pp.of_string "ppxlib.runner" , ppxlib
; Pp.of_string "ppx_driver.runner" , ppx_driver
[ Pp.of_string ~loc:None "ocaml-migrate-parsetree.driver-main" , omp
; Pp.of_string ~loc:None "ppxlib.runner" , ppxlib
; Pp.of_string ~loc:None "ppx_driver.runner" , ppx_driver
]
let get_driver pps =
@ -270,7 +272,7 @@ let build_ppx_driver sctx ~lib_db ~dep_kind ~target ~dir_kind pps =
(* Extend the dependency stack as we don't have locations at
this point *)
Dep_path.prepend_exn e
(Preprocess (pps : Dune_file.Pp.t list :> string list)))
(Preprocess (pps : Dune_file.Pp.t list :> Lib_name.t list)))
(Lib.DB.resolve_pps lib_db
(List.map pps ~f:(fun x -> (Loc.none, x)))
>>= Lib.closure
@ -321,7 +323,7 @@ let get_rules sctx key ~dir_kind =
| [] -> []
| driver :: rest -> List.sort rest ~compare:String.compare @ [driver]
in
let pps = List.map names ~f:Dune_file.Pp.of_string in
let pps = List.map names ~f:(Dune_file.Pp.of_string ~loc:None) in
build_ppx_driver sctx pps ~lib_db ~dep_kind:Required ~target:exe ~dir_kind
let gen_rules sctx components =
@ -334,10 +336,10 @@ let ppx_driver_exe sctx libs ~dir_kind =
let names =
let names = List.rev_map libs ~f:Lib.name in
match (dir_kind : File_tree.Dune_file.Kind.t) with
| Dune -> List.sort names ~compare:String.compare
| Dune -> List.sort names ~compare:Lib_name.compare
| Jbuild ->
match names with
| last :: others -> List.sort others ~compare:String.compare @ [last]
| last :: others -> List.sort others ~compare:Lib_name.compare @ [last]
| [] -> []
in
let scope_for_key =
@ -354,11 +356,7 @@ let ppx_driver_exe sctx libs ~dir_kind =
| None , Some _ -> scope_for_key
| None , None -> None)
in
let key =
match names with
| [] -> "+none+"
| _ -> String.concat names ~sep:"+"
in
let key = Lib_name.L.to_key names in
let key =
match scope_for_key with
| None -> key
@ -373,6 +371,7 @@ module Compat_ppx_exe_kind = struct
end
let get_compat_ppx_exe sctx ~name ~kind =
let name = Lib_name.to_string name in
match (kind : Compat_ppx_exe_kind.t) with
| Dune ->
ppx_exe sctx ~key:name ~dir_kind:Dune
@ -410,7 +409,8 @@ let workspace_root_var = String_with_vars.virt_var __POS__ "workspace_root"
let cookie_library_name lib_name =
match lib_name with
| None -> []
| Some name -> ["--cookie"; sprintf "library-name=%S" name]
| Some name ->
["--cookie"; sprintf "library-name=%S" (Lib_name.Local.to_string name)]
(* Generate rules for the reason modules in [modules] and return a
a new module with only OCaml sources *)

6
src/preprocessing.mli
View File

@ -15,7 +15,7 @@ val make
-> lint:Dune_file.Preprocess_map.t
-> preprocess:Dune_file.Preprocess_map.t
-> preprocessor_deps:(unit, Path.t list) Build.t
-> lib_name:string option
-> lib_name:Lib_name.Local.t option
-> scope:Scope.t
-> dir_kind:File_tree.Dune_file.Kind.t
-> t
@ -56,12 +56,12 @@ end
(** Compatibility [ppx.exe] program for the findlib method. *)
val get_compat_ppx_exe
: Super_context.t
-> name:string
-> name:Lib_name.t
-> kind:Compat_ppx_exe_kind.t
-> Path.t
(** [cookie_library_name lib_name] is ["--cookie"; lib_name] if [lib_name] is not
[None] *)
val cookie_library_name : string option -> string list
val cookie_library_name : Lib_name.Local.t option -> string list
val gen_rules : Super_context.t -> string list -> unit

10
src/scope.ml
View File

@ -79,7 +79,7 @@ module DB = struct
List.filter_map internal_libs ~f:(fun (_dir, lib) ->
Option.map lib.public ~f:(fun p ->
(Dune_file.Public_lib.name p, lib.project)))
|> String.Map.of_list
|> Lib_name.Map.of_list
|> function
| Ok x -> x
| Error (name, _, _) ->
@ -91,17 +91,17 @@ module DB = struct
with
| [] | [_] -> assert false
| loc1 :: loc2 :: _ ->
die "Public library %S is defined twice:\n\
die "Public library %a is defined twice:\n\
- %s\n\
- %s"
name
Lib_name.pp_quoted name
(Loc.to_file_colon_line loc1)
(Loc.to_file_colon_line loc2)
in
Lib.DB.create ()
~parent:installed_libs
~resolve:(fun name ->
match String.Map.find public_libs name with
match Lib_name.Map.find public_libs name with
| None -> Not_found
| Some project ->
let scope =
@ -109,7 +109,7 @@ module DB = struct
(Project_name_map.find !by_name_cell (Dune_project.name project))
in
Redirect (Some scope.db, name))
~all:(fun () -> String.Map.keys public_libs)
~all:(fun () -> Lib_name.Map.keys public_libs)
in
let by_name =
let build_context_dir = Path.relative Path.build_dir context in

4
src/stdune/fmt.ml
View File

@ -54,3 +54,7 @@ let record fmt = function
let tuple ppfa ppfb fmt (a, b) =
Format.fprintf fmt "@[<hv>(%a, %a)@]" ppfa a ppfb b
let optional ppf fmt = function
| None -> Format.fprintf fmt "<None>"
| Some a -> ppf fmt a

2
src/stdune/fmt.mli
View File

@ -24,3 +24,5 @@ val record : (string * unit t) list t
val tuple : 'a t -> 'b t -> ('a * 'b) t
val nl : unit t
val optional : 'a t -> 'a option t

5
src/sub_system.ml
View File

@ -40,7 +40,8 @@ module Register_backend(M : Backend) = struct
Lib.DB.resolve db (loc, name) >>= fun lib ->
match get lib with
| None ->
Error (Errors.exnf loc "%S is not %s %s" name M.desc_article
Error (Errors.exnf loc "%a is not %s %s" Lib_name.pp_quoted name
M.desc_article
(M.desc ~plural:false))
| Some t -> Ok t
@ -60,7 +61,7 @@ module Register_backend(M : Backend) = struct
(List.map backends ~f:(fun t ->
let lib = M.lib t in
sprintf "- %S in %s"
(Lib.name lib)
(Lib_name.to_string (Lib.name lib))
(Path.to_string_maybe_quoted (Lib.src_dir lib)))))
| No_backend_found ->
Errors.exnf loc "No %s found." (M.desc ~plural:false)

6
src/sub_system_intf.ml
View File

@ -12,7 +12,7 @@ module type S = sig
(** Create an instance of the sub-system *)
val instantiate
: resolve:(Loc.t * string -> Lib.t Or_exn.t)
: resolve:(Loc.t * Lib_name.t -> Lib.t Or_exn.t)
-> get:(loc:Loc.t -> Lib.t -> t option)
-> Lib.t
-> Info.t
@ -44,7 +44,7 @@ module type Registered_backend = sig
val get : Lib.t -> t option
(** Resolve a backend name *)
val resolve : Lib.DB.t -> Loc.t * string -> t Or_exn.t
val resolve : Lib.DB.t -> Loc.t * Lib_name.t -> t Or_exn.t
module Selection_error : sig
type nonrec t =
@ -105,7 +105,7 @@ module type End_point = sig
include Info
(** Additional backends specified by the user at use-site *)
val backends : t -> (Loc.t * string) list option
val backends : t -> (Loc.t * Lib_name.t) list option
end
val gen_rules

21
src/super_context.ml
View File

@ -71,16 +71,16 @@ let build_system t = t.build_system
let host t = Option.value t.host ~default:t
let internal_lib_names t =
List.fold_left t.stanzas ~init:String.Set.empty
List.fold_left t.stanzas ~init:Lib_name.Set.empty
~f:(fun acc { Dir_with_jbuild. stanzas; _ } ->
List.fold_left stanzas ~init:acc ~f:(fun acc -> function
| Library lib ->
String.Set.add
Lib_name.Set.add
(match lib.public with
| None -> acc
| Some { name = (_, name); _ } ->
String.Set.add acc name)
lib.name
Lib_name.Set.add acc name)
(Lib_name.of_local lib.name)
| _ -> acc))
let public_libs t = t.public_libs
@ -235,13 +235,13 @@ end = struct
let empty () =
{ failures = []
; lib_deps = String.Map.empty
; lib_deps = Lib_name.Map.empty
; sdeps = Path.Set.empty
; ddeps = String.Map.empty
}
let add_lib_dep acc lib kind =
acc.lib_deps <- String.Map.add acc.lib_deps lib kind
acc.lib_deps <- Lib_name.Map.add acc.lib_deps lib kind
let add_fail acc fail =
acc.failures <- fail :: acc.failures;
@ -261,7 +261,7 @@ end = struct
match String.lsplit2 s ~on:':' with
| None ->
Errors.fail loc "invalid %%{lib:...} form: %s" s
| Some x -> x
| Some (lib, f) -> (Lib_name.of_string_exn ~loc:(Some loc) lib, f)
open Build.O
@ -330,7 +330,7 @@ end = struct
end
end
| Macro (Lib_available, s) -> begin
let lib = s in
let lib = Lib_name.of_string_exn ~loc:(Some loc) s in
Resolved_forms.add_lib_dep acc lib Optional;
Some (str_exp (string_of_bool (
Lib.DB.available (Scope.libs scope) lib)))
@ -540,7 +540,8 @@ let create
List.filter_map stanzas ~f:(fun stanza ->
let keep =
match (stanza : Stanza.t) with
| Library lib -> Lib.DB.available (Scope.libs scope) lib.name
| Library lib ->
Lib.DB.available (Scope.libs scope) (Library.best_name lib)
| Documentation _
| Install _ -> true
| _ -> false
@ -696,7 +697,7 @@ module Libs = struct
prefix_rules t prefix ~f
let lib_files_alias ~dir ~name ~ext =
Alias.make (sprintf "lib-%s%s-all" name ext) ~dir
Alias.make (sprintf "lib-%s%s-all" (Lib_name.to_string name) ext) ~dir
let setup_file_deps_alias t ~dir ~ext lib files =
add_alias_deps t

2
src/super_context.mli
View File

@ -63,7 +63,7 @@ val public_libs : t -> Lib.DB.t
val installed_libs : t -> Lib.DB.t
(** All non-public library names *)
val internal_lib_names : t -> String.Set.t
val internal_lib_names : t -> Lib_name.Set.t
(** Compute the ocaml flags based on the directory environment and a
buildable stanza *)

2
src/utils.ml
View File

@ -107,7 +107,7 @@ let describe_target fn =
Path.to_string_maybe_quoted fn
let library_object_directory ~dir name =
Path.relative dir ("." ^ name ^ ".objs")
Path.relative dir ("." ^ Lib_name.Local.to_string name ^ ".objs")
(* Use "eobjs" rather than "objs" to avoid a potential conflict with a
library of the same name *)

2
src/utils.mli
View File

@ -19,7 +19,7 @@ val describe_target : Path.t -> string
library should be stored. *)
val library_object_directory
: dir:Path.t
-> string
-> Lib_name.Local.t
-> Path.t
(** Return the directory where the object files for the given

3
src/utop.ml
View File

@ -65,7 +65,8 @@ let setup sctx ~dir ~(libs : Library.t list) ~scope =
let requires =
let open Result.O in
Lib.DB.find_many (Scope.libs scope)
("utop" :: List.map libs ~f:(fun (lib : Library.t) -> lib.name))
(Lib_name.of_string_exn ~loc:None "utop"
:: List.map libs ~f:Library.best_name)
>>= Lib.closure
in
let cctx =

10
test/unit-tests/tests.mlt
View File

@ -11,9 +11,11 @@ let () =
;;
let print_pkg ppf pkg =
Format.fprintf ppf "<package:%s>" (Findlib.Package.name pkg)
Format.fprintf ppf "<package:%s>"
(Lib_name.to_string (Findlib.Package.name pkg))
;;
#install_printer Lib_name.pp_quoted;;
#install_printer print_pkg;;
#install_printer String.Map.pp;;
@ -33,7 +35,7 @@ val findlib : Findlib.t = <abstr>
|}]
let pkg =
match Findlib.find findlib "foo" with
match Findlib.find findlib (Lib_name.of_string_exn ~loc:None "foo") with
| Ok x -> x
| Error _ -> assert false;;
@ -45,7 +47,7 @@ val pkg : Findlib.Package.t = <package:foo>
Findlib.Package.requires pkg;;
[%%expect{|
- : string list = ["baz"]
- : Lib_name.t list = ["baz"]
|}]
(* +-----------------------------------------------------------------+
@ -57,7 +59,7 @@ open Meta
let meta =
Path.in_source "test/unit-tests/findlib-db/foo/META"
|> Meta.load ~name:"foo"
|> Meta.load ~name:(Some (Lib_name.of_string_exn ~loc:None "foo"))
[%%expect{|
val meta : Simplified.t =