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

Introduce private type for module name

This commit is contained in:
Rudi Grinberg 2018-03-04 01:03:37 +07:00
parent f20b43a22b
commit ddefafa58b
21 changed files with 214 additions and 141 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
src/exe.ml
View File

@ -6,7 +6,7 @@ module SC = Super_context
module Program = struct module Program = struct
type t = type t =
{ name : string { name : string
; main_module_name : string ; main_module_name : Module.Name.t
} }
end end
@ -123,7 +123,7 @@ let build_and_link_many
sctx sctx
= =
let modules = let modules =
String_map.map modules ~f:(Module.set_obj_name ~wrapper:None) Module.Name.Map.map modules ~f:(Module.set_obj_name ~wrapper:None)
in in
let dep_graphs = let dep_graphs =
@ -139,7 +139,8 @@ let build_and_link_many
List.iter programs ~f:(fun { Program.name; main_module_name } -> List.iter programs ~f:(fun { Program.name; main_module_name } ->
let top_sorted_modules = let top_sorted_modules =
let main = Option.value_exn (String_map.find modules main_module_name) in let main = Option.value_exn
(Module.Name.Map.find modules main_module_name) in
Ocamldep.Dep_graph.top_closed_implementations dep_graphs.impl Ocamldep.Dep_graph.top_closed_implementations dep_graphs.impl
[main] [main]
in in

12
src/exe.mli
View File

@ -1,11 +1,9 @@
(** Compilation and linking of executables *) (** Compilation and linking of executables *)
open Import
module Program : sig module Program : sig
type t = type t =
{ name : string { name : string
; main_module_name : string ; main_module_name : Module.Name.t
} }
end end
@ -40,11 +38,11 @@ val build_and_link
: dir:Path.t : dir:Path.t
-> obj_dir:Path.t -> obj_dir:Path.t
-> program:Program.t -> program:Program.t
-> modules:Module.t String_map.t -> modules:Module.t Module.Name.Map.t
-> scope:Scope.t -> scope:Scope.t
-> linkages:Linkage.t list -> linkages:Linkage.t list
-> ?requires:(unit, Lib.L.t) Build.t -> ?requires:(unit, Lib.L.t) Build.t
-> ?already_used:String_set.t -> ?already_used:Module.Name.Set.t
-> ?flags:Ocaml_flags.t -> ?flags:Ocaml_flags.t
-> ?link_flags:(unit, string list) Build.t -> ?link_flags:(unit, string list) Build.t
-> ?js_of_ocaml:Jbuild.Js_of_ocaml.t -> ?js_of_ocaml:Jbuild.Js_of_ocaml.t
@ -55,11 +53,11 @@ val build_and_link_many
: dir:Path.t : dir:Path.t
-> obj_dir:Path.t -> obj_dir:Path.t
-> programs:Program.t list -> programs:Program.t list
-> modules:Module.t String_map.t -> modules:Module.t Module.Name.Map.t
-> scope:Scope.t -> scope:Scope.t
-> linkages:Linkage.t list -> linkages:Linkage.t list
-> ?requires:(unit, Lib.L.t) Build.t -> ?requires:(unit, Lib.L.t) Build.t
-> ?already_used:String_set.t -> ?already_used:Module.Name.Set.t
-> ?flags:Ocaml_flags.t -> ?flags:Ocaml_flags.t
-> ?link_flags:(unit, string list) Build.t -> ?link_flags:(unit, string list) Build.t
-> ?js_of_ocaml:Jbuild.Js_of_ocaml.t -> ?js_of_ocaml:Jbuild.Js_of_ocaml.t

136
src/gen_rules.ml
View File

@ -25,34 +25,40 @@ module Gen(P : Install_rules.Params) = struct
+-----------------------------------------------------------------+ *) +-----------------------------------------------------------------+ *)
module Eval_modules = Ordered_set_lang.Make(struct module Eval_modules = Ordered_set_lang.Make(struct
type t = (Module.t, string * Loc.t) result type t = (Module.t, Module.Name.t * Loc.t) result
let name = function let name r = (
| Error (s, _) -> s (match r with
| Ok m -> Module.name m | Error (s, _) -> s
| Ok m -> Module.name m)
|> Module.Name.to_string
)
end) end)
let parse_modules ~(all_modules : Module.t String_map.t) ~buildable = let parse_modules ~(all_modules : Module.t Module.Name.Map.t) ~buildable =
let conf : Buildable.t = buildable in let conf : Buildable.t = buildable in
let standard_modules = String_map.map all_modules ~f:(fun m -> Ok m) in let standard_modules = Module.Name.Map.map all_modules ~f:(fun m -> Ok m) in
let fake_modules = ref String_map.empty in let fake_modules = ref Module.Name.Map.empty in
let parse ~loc s = let parse ~loc s =
let s = String.capitalize s in let name = Module.Name.of_string s in
match String_map.find all_modules s with match Module.Name.Map.find all_modules name with
| Some m -> Ok m | Some m -> Ok m
| None -> | None ->
fake_modules := String_map.add !fake_modules s loc; fake_modules := Module.Name.Map.add !fake_modules name loc;
Error (s, loc) Error (name, loc)
in in
let modules = let modules =
let standard = Module.Name.Map.to_smap standard_modules in
Eval_modules.eval_unordered Eval_modules.eval_unordered
conf.modules conf.modules
~parse ~parse
~standard:standard_modules ~standard
|> Module.Name.Map.of_smap
in in
let only_present_modules modules = let only_present_modules modules =
String_map.filter_map ~f:(function Module.Name.Map.filter_map ~f:(function
| Ok m -> Some m | Ok m -> Some m
| Error (s, loc) -> Loc.fail loc "Module %s doesn't exist." s | Error (s, loc) ->
Loc.fail loc "Module %a doesn't exist." Module.Name.pp s
) modules ) modules
in in
let modules = only_present_modules modules in let modules = only_present_modules modules in
@ -61,27 +67,31 @@ module Gen(P : Install_rules.Params) = struct
conf.modules_without_implementation conf.modules_without_implementation
~parse ~parse
~standard:String_map.empty ~standard:String_map.empty
|> Module.Name.Map.of_smap
in in
let intf_only = only_present_modules intf_only in let intf_only = only_present_modules intf_only in
String_map.iteri !fake_modules ~f:(fun m loc -> Module.Name.Map.iteri !fake_modules ~f:(fun m loc ->
Loc.warn loc "Module %s is excluded but it doesn't exist." m Loc.warn loc "Module %a is excluded but it doesn't exist."
Module.Name.pp m
); );
let real_intf_only = let real_intf_only =
String_map.filter modules Module.Name.Map.filter modules
~f:(fun (m : Module.t) -> Option.is_none m.impl) ~f:(fun (m : Module.t) -> Option.is_none m.impl)
in in
if String_map.equal intf_only real_intf_only if Module.Name.Map.equal intf_only real_intf_only
~equal:(fun a b -> Module.name a = Module.name b) then ~equal:(fun a b -> Module.name a = Module.name b) then
modules modules
else begin else begin
let should_be_listed, shouldn't_be_listed = let should_be_listed, shouldn't_be_listed =
String_map.merge intf_only real_intf_only ~f:(fun name x y -> Module.Name.Map.merge intf_only real_intf_only ~f:(fun name x y ->
match x, y with match x, y with
| Some _, Some _ -> None | Some _, Some _ -> None
| None , Some _ -> Some (Left (String.uncapitalize name)) | None , Some _ ->
| Some _, None -> Some (Right (String.uncapitalize name)) Some (Left (String.uncapitalize (Module.Name.to_string name)))
| Some _, None ->
Some (Right (String.uncapitalize (Module.Name.to_string name)))
| None , None -> assert false) | None , None -> assert false)
|> String_map.values |> Module.Name.Map.values
|> List.partition_map ~f:(fun x -> x) |> List.partition_map ~f:(fun x -> x)
in in
let list_modules l = let list_modules l =
@ -116,17 +126,18 @@ module Gen(P : Install_rules.Params) = struct
let module Eval = let module Eval =
Ordered_set_lang.Make(struct Ordered_set_lang.Make(struct
type t = Loc.t * Module.t type t = Loc.t * Module.t
let name (_, m) = Module.name m let name (_, m) = Module.Name.to_string (Module.name m)
end) end)
in in
let parse ~loc s = let parse ~loc s =
let s = String.capitalize s in let name = Module.Name.of_string s in
match String_map.find all_modules s with match Module.Name.Map.find all_modules name with
| Some m -> m | Some m -> m
| None -> Loc.fail loc "Module %s doesn't exist." s | None -> Loc.fail loc "Module %s doesn't exist." s
in in
let parse ~loc s = (loc, parse ~loc s) in let parse ~loc s = (loc, parse ~loc s) in
let shouldn't_be_listed = let shouldn't_be_listed =
let all_modules = Module.Name.Map.to_smap all_modules in
Eval.eval_unordered conf.modules_without_implementation Eval.eval_unordered conf.modules_without_implementation
~parse ~parse
~standard:(String_map.map all_modules ~f:(fun m -> (Loc.none, m))) ~standard:(String_map.map all_modules ~f:(fun m -> (Loc.none, m)))
@ -137,8 +148,8 @@ module Gen(P : Install_rules.Params) = struct
(* CR-soon jdimino for jdimino: report all errors *) (* CR-soon jdimino for jdimino: report all errors *)
let loc, m = List.hd shouldn't_be_listed in let loc, m = List.hd shouldn't_be_listed in
Loc.fail loc Loc.fail loc
"Module %s has an implementation, it cannot be listed here" "Module %a has an implementation, it cannot be listed here"
m.name Module.Name.pp m.name
end; end;
modules modules
end end
@ -264,18 +275,19 @@ module Gen(P : Install_rules.Params) = struct
in in
let parse_one_set files = let parse_one_set files =
List.map files ~f:(fun (f : Module.File.t) -> List.map files ~f:(fun (f : Module.File.t) ->
(String.capitalize (Filename.chop_extension f.name), f)) (Module.Name.of_string (Filename.chop_extension f.name), f))
|> String_map.of_list |> Module.Name.Map.of_list
|> function |> function
| Ok x -> x | Ok x -> x
| Error (name, f1, f2) -> | Error (name, f1, f2) ->
let src_dir = Path.drop_build_context_exn dir in let src_dir = Path.drop_build_context_exn dir in
die "too many files for module %s in %s: %s and %s" die "too many files for module %a in %s: %s and %s"
name (Path.to_string src_dir) f1.name f2.name Module.Name.pp name (Path.to_string src_dir)
f1.name f2.name
in in
let impls = parse_one_set impl_files in let impls = parse_one_set impl_files in
let intfs = parse_one_set intf_files in let intfs = parse_one_set intf_files in
String_map.merge impls intfs ~f:(fun name impl intf -> Module.Name.Map.merge impls intfs ~f:(fun name impl intf ->
Some Some
{ Module.name { Module.name
; impl ; impl
@ -292,9 +304,9 @@ module Gen(P : Install_rules.Params) = struct
guess_modules ~dir ~files) guess_modules ~dir ~files)
type modules_by_lib = type modules_by_lib =
{ modules : Module.t String_map.t { modules : Module.t Module.Name.Map.t
; alias_module : Module.t option ; alias_module : Module.t option
; main_module_name : string ; main_module_name : Module.Name.t
} }
let modules_by_lib = let modules_by_lib =
@ -305,9 +317,9 @@ module Gen(P : Install_rules.Params) = struct
let modules = let modules =
parse_modules ~all_modules ~buildable:lib.buildable parse_modules ~all_modules ~buildable:lib.buildable
in in
let main_module_name = String.capitalize lib.name in let main_module_name = Module.Name.of_string lib.name in
let modules = let modules =
String_map.map modules ~f:(fun (m : Module.t) -> Module.Name.Map.map modules ~f:(fun (m : Module.t) ->
let wrapper = let wrapper =
if not lib.wrapped || m.name = main_module_name then if not lib.wrapped || m.name = main_module_name then
None None
@ -318,16 +330,16 @@ module Gen(P : Install_rules.Params) = struct
in in
let alias_module = let alias_module =
if not lib.wrapped || if not lib.wrapped ||
(String_map.cardinal modules = 1 && (Module.Name.Map.cardinal modules = 1 &&
String_map.mem modules main_module_name) then Module.Name.Map.mem modules main_module_name) then
None None
else if String_map.mem modules main_module_name then else if Module.Name.Map.mem modules main_module_name then
(* This module needs an implementaion for non-jbuilder (* This module needs an implementaion for non-jbuilder
users of the library: users of the library:
https://github.com/ocaml/dune/issues/567 *) https://github.com/ocaml/dune/issues/567 *)
Some Some
{ Module.name = main_module_name ^ "__" { Module.name = Module.Name.add_suffix main_module_name "__"
; intf = None ; intf = None
; impl = Some { name = sprintf "%s__.ml-gen" lib.name ; impl = Some { name = sprintf "%s__.ml-gen" lib.name
; syntax = OCaml ; syntax = OCaml
@ -351,9 +363,9 @@ module Gen(P : Install_rules.Params) = struct
let modules = let modules =
match alias_module with match alias_module with
| None -> modules | None -> modules
| Some m -> String_map.add modules m.name m | Some m -> Module.Name.Map.add modules m.name m
in in
String_map.values modules Module.Name.Map.values modules
(* +-----------------------------------------------------------------+ (* +-----------------------------------------------------------------+
| Library stuff | | Library stuff |
@ -519,15 +531,16 @@ module Gen(P : Install_rules.Params) = struct
let modules = let modules =
match alias_module with match alias_module with
| None -> modules | None -> modules
| Some m -> String_map.add modules m.name m | Some m -> Module.Name.Map.add modules m.name m
in in
let dep_graphs = let dep_graphs =
Ocamldep.rules sctx ~dir ~modules ~already_used ~alias_module Ocamldep.rules sctx ~dir ~modules ~already_used ~alias_module
~lib_interface_module:(if lib.wrapped then ~lib_interface_module:(
String_map.find modules main_module_name if lib.wrapped then
else Module.Name.Map.find modules main_module_name
None) else
None)
in in
Option.iter alias_module ~f:(fun m -> Option.iter alias_module ~f:(fun m ->
@ -538,12 +551,15 @@ module Gen(P : Install_rules.Params) = struct
in in
SC.add_rule sctx SC.add_rule sctx
(Build.return (Build.return
(String_map.values (String_map.remove modules m.name) (Module.Name.Map.values (Module.Name.Map.remove modules m.name)
|> List.map ~f:(fun (m : Module.t) -> |> List.map ~f:(fun (m : Module.t) ->
sprintf "(** @canonical %s.%s *)\n\ sprintf "(** @canonical %s.%s *)\n\
module %s = %s\n" module %s = %s\n"
main_module_name m.name (Module.Name.to_string main_module_name)
m.name (Module.real_unit_name m)) (Module.Name.to_string m.name)
(Module.Name.to_string m.name)
(Module.Name.to_string (Module.real_unit_name m))
)
|> String.concat ~sep:"\n") |> String.concat ~sep:"\n")
>>> Build.write_file_dyn (Path.relative dir file.name))); >>> Build.write_file_dyn (Path.relative dir file.name)));
@ -571,7 +587,7 @@ module Gen(P : Install_rules.Params) = struct
~dep_graphs:(Ocamldep.Dep_graphs.dummy m) ~dep_graphs:(Ocamldep.Dep_graphs.dummy m)
~requires:( ~requires:(
let requires = let requires =
if String_map.is_empty modules then if Module.Name.Map.is_empty modules then
(* Just so that we setup lib dependencies for empty libraries *) (* Just so that we setup lib dependencies for empty libraries *)
requires requires
else else
@ -645,7 +661,7 @@ module Gen(P : Install_rules.Params) = struct
List.iter Cm_kind.all ~f:(fun cm_kind -> List.iter Cm_kind.all ~f:(fun cm_kind ->
let files = let files =
String_map.fold modules ~init:[] ~f:(fun m acc -> Module.Name.Map.fold modules ~init:[] ~f:(fun m acc ->
match Module.cm_file m ~obj_dir cm_kind with match Module.cm_file m ~obj_dir cm_kind with
| None -> acc | None -> acc
| Some fn -> fn :: acc) | Some fn -> fn :: acc)
@ -659,7 +675,7 @@ module Gen(P : Install_rules.Params) = struct
let top_sorted_modules = let top_sorted_modules =
Ocamldep.Dep_graph.top_closed_implementations dep_graphs.impl Ocamldep.Dep_graph.top_closed_implementations dep_graphs.impl
(String_map.values modules) (Module.Name.Map.values modules)
in in
List.iter Mode.all ~f:(fun mode -> List.iter Mode.all ~f:(fun mode ->
build_lib lib ~scope ~flags ~dir ~obj_dir ~mode ~top_sorted_modules); build_lib lib ~scope ~flags ~dir ~obj_dir ~mode ~top_sorted_modules);
@ -712,7 +728,7 @@ module Gen(P : Install_rules.Params) = struct
match alias_module with match alias_module with
| None -> Ocaml_flags.common flags | None -> Ocaml_flags.common flags
| Some m -> | Some m ->
Ocaml_flags.prepend_common ["-open"; m.name] flags Ocaml_flags.prepend_common ["-open"; Module.Name.to_string m.name] flags
|> Ocaml_flags.common |> Ocaml_flags.common
in in
@ -743,7 +759,7 @@ module Gen(P : Install_rules.Params) = struct
in in
let already_used = let already_used =
match modules_partitioner with match modules_partitioner with
| None -> String_set.empty | None -> Module.Name.Set.empty
| Some mp -> | Some mp ->
Modules_partitioner.acknowledge mp Modules_partitioner.acknowledge mp
~loc:exes.buildable.loc ~modules ~loc:exes.buildable.loc ~modules
@ -763,14 +779,16 @@ module Gen(P : Install_rules.Params) = struct
let programs = let programs =
List.map exes.names ~f:(fun (loc, name) -> List.map exes.names ~f:(fun (loc, name) ->
let mod_name = String.capitalize name in let mod_name = Module.Name.of_string name in
match String_map.find modules mod_name with match Module.Name.Map.find modules mod_name with
| Some m -> | Some m ->
if not (Module.has_impl m) then if not (Module.has_impl m) then
Loc.fail loc "Module %s has no implementation." mod_name Loc.fail loc "Module %a has no implementation."
Module.Name.pp mod_name
else else
{ Exe.Program.name; main_module_name = mod_name } { Exe.Program.name; main_module_name = mod_name }
| None -> Loc.fail loc "Module %s doesn't exist." mod_name) | None -> Loc.fail loc "Module %a doesn't exist."
Module.Name.pp mod_name)
in in
let linkages = let linkages =

2
src/import.ml
View File

@ -128,6 +128,8 @@ module Fmt = struct
let list = Format.pp_print_list let list = Format.pp_print_list
let string s ppf = Format.pp_print_string ppf s let string s ppf = Format.pp_print_string ppf s
let nl = Format.pp_print_newline
let prefix f g ppf x = f ppf; g ppf x let prefix f g ppf x = f ppf; g ppf x
end end

8
src/inline_tests.ml
View File

@ -172,9 +172,9 @@ include Sub_system.Register_end_point(
let name = "run" in let name = "run" in
let main_module_filename = name ^ ".ml" in let main_module_filename = name ^ ".ml" in
let main_module_name = String.capitalize name in let main_module_name = Module.Name.of_string name in
let modules = let modules =
String_map.singleton main_module_name Module.Name.Map.singleton main_module_name
{ Module. { Module.
name = main_module_name name = main_module_name
; impl = Some { name = main_module_filename ; impl = Some { name = main_module_filename
@ -205,7 +205,7 @@ include Sub_system.Register_end_point(
(* Generate the runner file *) (* Generate the runner file *)
SC.add_rule sctx ( SC.add_rule sctx (
let target = Path.relative inline_test_dir main_module_filename in let target = Path.relative inline_test_dir main_module_filename in
let source_modules = String_map.values source_modules in let source_modules = Module.Name.Map.values source_modules in
let files ml_kind = let files ml_kind =
Action.Var_expansion.Paths ( Action.Var_expansion.Paths (
List.filter_map source_modules ~f:(fun m -> List.filter_map source_modules ~f:(fun m ->
@ -274,7 +274,7 @@ include Sub_system.Register_end_point(
A.chdir dir A.chdir dir
(A.progn (A.progn
(A.run (Ok exe) flags :: (A.run (Ok exe) flags ::
(String_map.values source_modules (Module.Name.Map.values source_modules
|> List.concat_map ~f:(fun m -> |> List.concat_map ~f:(fun m ->
[ Module.file m ~dir Impl [ Module.file m ~dir Impl
; Module.file m ~dir Intf ; Module.file m ~dir Intf

9
src/jbuild.ml
View File

@ -288,19 +288,20 @@ module Preprocess = struct
end end
module Per_module = struct module Per_module = struct
include Per_item.Make(String) include Per_item.Make(Module.Name)
let t ~default a sexp = let t ~default a sexp =
match sexp with match sexp with
| List (_, Atom (_, A "per_module") :: rest) -> begin | List (_, Atom (_, A "per_module") :: rest) -> begin
List.map rest ~f:(fun sexp -> List.map rest ~f:(fun sexp ->
let pp, names = pair a module_names sexp in let pp, names = pair a module_names sexp in
(String_set.to_list names, pp)) (List.map ~f:Module.Name.of_string (String_set.to_list names), pp))
|> of_mapping ~default |> of_mapping ~default
|> function |> function
| Ok t -> t | Ok t -> t
| Error (name, _, _) -> | Error (name, _, _) ->
of_sexp_error sexp (sprintf "module %s present in two different sets" name) of_sexp_error sexp (sprintf "module %s present in two different sets"
(Module.Name.to_string name))
end end
| sexp -> for_all (a sexp) | sexp -> for_all (a sexp)
end end
@ -516,7 +517,7 @@ module Buildable = struct
let single_preprocess t = let single_preprocess t =
if Per_module.is_constant t.preprocess then if Per_module.is_constant t.preprocess then
Per_module.get t.preprocess "" Per_module.get t.preprocess (Module.Name.of_string "")
else else
Preprocess.No_preprocessing Preprocess.No_preprocessing
end end

4
src/jbuild.mli
View File

@ -61,7 +61,7 @@ module Preprocess : sig
| Pps of pps | Pps of pps
end end
module Per_module : Per_item.S with type key = string module Per_module : Per_item.S with type key = Module.Name.t
module Preprocess_map : sig module Preprocess_map : sig
type t = Preprocess.t Per_module.t type t = Preprocess.t Per_module.t
@ -71,7 +71,7 @@ module Preprocess_map : sig
(** [find module_name] find the preprocessing specification for a (** [find module_name] find the preprocessing specification for a
given module *) given module *)
val find : string -> t -> Preprocess.t val find : Module.Name.t -> t -> Preprocess.t
val pps : t -> (Loc.t * Pp.t) list val pps : t -> (Loc.t * Pp.t) list
end end

31
src/module.ml
View File

@ -1,5 +1,32 @@
open Import open Import
module Name = struct
type t = string
let t = Sexp.atom
let add_suffix = (^)
let compare = compare
let of_string = String.capitalize
let to_string x = x
let pp = Format.pp_print_string
let pp_quote fmt x = Format.fprintf fmt "%S" x
module Set = struct
include String_set
let of_sset x = x
end
module Map = struct
include String_map
let to_smap x = x
let of_smap x = x
end
end
module Syntax = struct module Syntax = struct
type t = OCaml | Reason type t = OCaml | Reason
end end
@ -26,7 +53,7 @@ module File = struct
end end
type t = type t =
{ name : string { name : Name.t
; impl : File.t option ; impl : File.t option
; intf : File.t option ; intf : File.t option
; obj_name : string ; obj_name : string
@ -34,7 +61,7 @@ type t =
let name t = t.name let name t = t.name
let real_unit_name t = String.capitalize (Filename.basename t.obj_name) let real_unit_name t = Name.of_string (Filename.basename t.obj_name)
let has_impl t = Option.is_some t.impl let has_impl t = Option.is_some t.impl

32
src/module.mli
View File

@ -1,5 +1,31 @@
open! Import open! Import
module Name : sig
type t = private string
val add_suffix : t -> string -> t
val t : t Sexp.To_sexp.t
val compare : t -> t -> Ordering.t
val of_string : string -> t
val to_string : t -> string
val pp : Format.formatter -> t -> unit
val pp_quote : Format.formatter -> t -> unit
module Set : sig
include Set.S with type elt = t
val of_sset : String_set.t -> t
end
module Map : sig
include Map.S with type key = t
val to_smap : 'a t -> 'a String_map.t
val of_smap : 'a String_map.t -> 'a t
end
end
module Syntax : sig module Syntax : sig
type t = OCaml | Reason type t = OCaml | Reason
end end
@ -14,7 +40,7 @@ module File : sig
end end
type t = type t =
{ name : string (** Name of the module. This is always the basename of the filename { name : Name.t (** Name of the module. This is always the basename of the filename
without the extension. *) without the extension. *)
; impl : File.t option ; impl : File.t option
; intf : File.t option ; intf : File.t option
@ -23,10 +49,10 @@ type t =
modules. *) modules. *)
} }
val name : t -> string val name : t -> Name.t
(** Real unit name once wrapped. This is always a valid module name. *) (** Real unit name once wrapped. This is always a valid module name. *)
val real_unit_name : t -> string val real_unit_name : t -> Name.t
val file : t -> dir: Path.t -> Ml_kind.t -> Path.t option val file : t -> dir: Path.t -> Ml_kind.t -> Path.t option
val cm_source : t -> dir: Path.t -> Cm_kind.t -> Path.t option val cm_source : t -> dir: Path.t -> Cm_kind.t -> Path.t option

7
src/module_compilation.ml
View File

@ -103,7 +103,8 @@ let build_cm sctx ?sandbox ~dynlink ~flags ~cm_kind ~dep_graphs
; A "-I"; Path obj_dir ; A "-I"; Path obj_dir
; (match alias_module with ; (match alias_module with
| None -> S [] | None -> S []
| Some (m : Module.t) -> As ["-open"; m.name]) | Some (m : Module.t) ->
As ["-open"; Module.Name.to_string m.name])
; A "-o"; Target dst ; A "-o"; Target dst
; A "-c"; Ml_kind.flag ml_kind; Dep src ; A "-c"; Ml_kind.flag ml_kind; Dep src
]))) ])))
@ -143,10 +144,10 @@ let build_modules sctx ~dynlink ~js_of_ocaml ~flags ~scope ~dir ~obj_dir
; cmx = cmi_and_cmx_requires ; cmx = cmi_and_cmx_requires
} }
in in
String_map.iter Module.Name.Map.iter
(match alias_module with (match alias_module with
| None -> modules | None -> modules
| Some (m : Module.t) -> String_map.remove modules m.name) | Some (m : Module.t) -> Module.Name.Map.remove modules m.name)
~f:(fun m -> ~f:(fun m ->
build_module sctx m ~dynlink ~js_of_ocaml ~flags ~scope ~dir ~obj_dir build_module sctx m ~dynlink ~js_of_ocaml ~flags ~scope ~dir ~obj_dir
~dep_graphs ~requires ~alias_module) ~dep_graphs ~requires ~alias_module)

4
src/module_compilation.mli
View File

@ -1,7 +1,5 @@
(** OCaml module compilation *) (** OCaml module compilation *)
open Import
(** Setup rules to build a single module. (** Setup rules to build a single module.
[requires] must declare dependencies on files of libraries. [requires] must declare dependencies on files of libraries.
@ -31,7 +29,7 @@ val build_modules
-> dir:Path.t -> dir:Path.t
-> obj_dir:Path.t -> obj_dir:Path.t
-> dep_graphs:Ocamldep.Dep_graphs.t -> dep_graphs:Ocamldep.Dep_graphs.t
-> modules:Module.t String_map.t -> modules:Module.t Module.Name.Map.t
-> requires:(unit, Lib.t list) Build.t -> requires:(unit, Lib.t list) Build.t
-> alias_module:Module.t option -> alias_module:Module.t option
-> unit -> unit

20
src/modules_partitioner.ml
View File

@ -2,25 +2,25 @@ open Import
type t = type t =
{ dir : Path.t { dir : Path.t
; all_modules : Module.t String_map.t ; all_modules : Module.t Module.Name.Map.t
; mutable used : Loc.t list String_map.t ; mutable used : Loc.t list Module.Name.Map.t
} }
let create ~dir ~all_modules = let create ~dir ~all_modules =
{ dir { dir
; all_modules ; all_modules
; used = String_map.empty ; used = Module.Name.Map.empty
} }
let acknowledge t ~loc ~modules = let acknowledge t ~loc ~modules =
let already_used = let already_used =
String_map.merge modules t.used ~f:(fun _name x l -> Module.Name.Map.merge modules t.used ~f:(fun _name x l ->
Option.some_if (Option.is_some x && Option.is_some l) ()) Option.some_if (Option.is_some x && Option.is_some l) ())
|> String_map.keys |> Module.Name.Map.keys
|> String_set.of_list |> Module.Name.Set.of_list
in in
t.used <- t.used <-
String_map.merge modules t.used ~f:(fun _name x l -> Module.Name.Map.merge modules t.used ~f:(fun _name x l ->
match x with match x with
| None -> l | None -> l
| Some _ -> Some (loc :: Option.value l ~default:[])); | Some _ -> Some (loc :: Option.value l ~default:[]));
@ -32,14 +32,14 @@ let emit_warnings t =
|> Path.to_string |> Path.to_string
|> Loc.in_file |> Loc.in_file
in in
String_map.iteri t.used ~f:(fun name locs -> Module.Name.Map.iteri t.used ~f:(fun name locs ->
if List.length locs > 1 then if List.length locs > 1 then
Loc.warn loc Loc.warn loc
"Module %S is used in several stanzas:@\n\ "Module %a is used in several stanzas:@\n\
@[<v>%a@]@\n\ @[<v>%a@]@\n\
@[%a@]@\n\ @[%a@]@\n\
This warning will become an error in the future." This warning will become an error in the future."
name Module.Name.pp_quote name
(Fmt.list (Fmt.prefix (Fmt.string "- ") Loc.pp_file_colon_line)) (Fmt.list (Fmt.prefix (Fmt.string "- ") Loc.pp_file_colon_line))
locs locs
Format.pp_print_text Format.pp_print_text

8
src/modules_partitioner.mli
View File

@ -1,12 +1,10 @@
(** Checks modules partitioning inside a directory *) (** Checks modules partitioning inside a directory *)
open Import
type t type t
val create val create
: dir:Path.t : dir:Path.t
-> all_modules:Module.t String_map.t -> all_modules:Module.t Module.Name.Map.t
-> t -> t
(** [acknowledge t ~loc ~modules] registers the fact that [modules] (** [acknowledge t ~loc ~modules] registers the fact that [modules]
@ -18,8 +16,8 @@ val create
val acknowledge val acknowledge
: t : t
-> loc:Loc.t -> loc:Loc.t
-> modules:Module.t String_map.t -> modules:Module.t Module.Name.Map.t
-> String_set.t -> Module.Name.Set.t
(** To be called after processing a directory. Emit warnings about (** To be called after processing a directory. Emit warnings about
detected problems *) detected problems *)

47
src/ocamldep.ml
View File

@ -6,39 +6,41 @@ module SC = Super_context
module Dep_graph = struct module Dep_graph = struct
type t = type t =
{ dir : Path.t { dir : Path.t
; per_module : (unit, Module.t list) Build.t String_map.t ; per_module : (unit, Module.t list) Build.t Module.Name.Map.t
} }
let deps_of t (m : Module.t) = let deps_of t (m : Module.t) =
match String_map.find t.per_module m.name with match Module.Name.Map.find t.per_module m.name with
| Some x -> x | Some x -> x
| None -> | None ->
Sexp.code_error "Ocamldep.Dep_graph.deps_of" Sexp.code_error "Ocamldep.Dep_graph.deps_of"
[ "dir", Path.sexp_of_t t.dir [ "dir", Path.sexp_of_t t.dir
; "modules", Sexp.To_sexp.(list string) (String_map.keys t.per_module) ; "modules", Sexp.To_sexp.(list Module.Name.t)
; "module", Sexp.atom m.name (Module.Name.Map.keys t.per_module)
; "module", Module.Name.t m.name
] ]
module Dep_closure = module Dep_closure =
Top_closure.Make(String)(struct Top_closure.Make(Module.Name)(struct
type t = Module.t type t = Module.t
type graph = t list String_map.t type graph = t list Module.Name.Map.t
let key (t : t) = t.name let key (t : t) = t.name
let deps t map = Option.value_exn (String_map.find map (key t)) let deps t map = Option.value_exn (Module.Name.Map.find map (key t))
end) end)
let top_closed t modules = let top_closed t modules =
Build.all Build.all
(List.map (String_map.to_list t.per_module) ~f:(fun (unit, deps) -> (List.map (Module.Name.Map.to_list t.per_module) ~f:(fun (unit, deps) ->
deps >>^ fun deps -> (unit, deps))) deps >>^ fun deps -> (unit, deps)))
>>^ fun per_module -> >>^ fun per_module ->
let per_module = String_map.of_list_exn per_module in let per_module = Module.Name.Map.of_list_exn per_module in
match Dep_closure.top_closure per_module modules with match Dep_closure.top_closure per_module modules with
| Ok modules -> modules | Ok modules -> modules
| Error cycle -> | Error cycle ->
die "dependency cycle between modules in %s:\n %s" (Path.to_string t.dir) die "dependency cycle between modules in %s:\n %a"
(String.concat ~sep:"\n-> " (Path.to_string t.dir)
(List.map cycle ~f:Module.name)) (Fmt.list ~pp_sep:Fmt.nl (Fmt.prefix (Fmt.string "-> ") Module.Name.pp))
(List.map cycle ~f:Module.name)
let top_closed_implementations t modules = let top_closed_implementations t modules =
Build.memoize "top sorted implementations" ( Build.memoize "top sorted implementations" (
@ -48,7 +50,7 @@ module Dep_graph = struct
let dummy (m : Module.t) = let dummy (m : Module.t) =
{ dir = Path.root { dir = Path.root
; per_module = String_map.singleton m.name (Build.return []) ; per_module = Module.Name.Map.singleton m.name (Build.return [])
} }
end end
@ -83,10 +85,11 @@ let parse_deps ~dir ~file ~(unit : Module.t)
String.extract_blank_separated_words String.extract_blank_separated_words
(String.sub line ~pos:(i + 1) ~len:(String.length line - (i + 1))) (String.sub line ~pos:(i + 1) ~len:(String.length line - (i + 1)))
|> List.filter_map ~f:(fun m -> |> List.filter_map ~f:(fun m ->
let m = Module.Name.of_string m in
if m = unit.name then if m = unit.name then
None None
else else
String_map.find modules m) Module.Name.Map.find modules m)
in in
(match lib_interface_module with (match lib_interface_module with
| None -> () | None -> ()
@ -98,15 +101,17 @@ let parse_deps ~dir ~file ~(unit : Module.t)
in in
if unit.name <> m.name && not is_alias_module && if unit.name <> m.name && not is_alias_module &&
List.exists deps ~f:(fun x -> Module.name x = m.name) then List.exists deps ~f:(fun x -> Module.name x = m.name) then
die "Module %s in directory %s depends on %s.\n\ die "Module %a in directory %s depends on %a.\n\
This doesn't make sense to me.\n\ This doesn't make sense to me.\n\
\n\ \n\
%s is the main module of the library and is \ %a is the main module of the library and is \
the only module exposed \n\ the only module exposed \n\
outside of the library. Consequently, it should \ outside of the library. Consequently, it should \
be the one depending \n\ be the one depending \n\
on all the other modules in the library." on all the other modules in the library."
unit.name (Path.to_string dir) m.name m.name); Module.Name.pp unit.name (Path.to_string dir)
Module.Name.pp m.name
Module.Name.pp m.name);
let deps = let deps =
match alias_module with match alias_module with
| None -> deps | None -> deps
@ -115,16 +120,16 @@ let parse_deps ~dir ~file ~(unit : Module.t)
deps deps
let rules ~(ml_kind:Ml_kind.t) ~dir ~modules let rules ~(ml_kind:Ml_kind.t) ~dir ~modules
?(already_used=String_set.empty) ?(already_used=Module.Name.Set.empty)
~alias_module ~lib_interface_module sctx = ~alias_module ~lib_interface_module sctx =
let per_module = let per_module =
String_map.map modules ~f:(fun unit -> Module.Name.Map.map modules ~f:(fun unit ->
match Module.file ~dir unit ml_kind with match Module.file ~dir unit ml_kind with
| None -> Build.return [] | None -> Build.return []
| Some file -> | Some file ->
let ocamldep_output = Path.extend_basename file ~suffix:".d" in let ocamldep_output = Path.extend_basename file ~suffix:".d" in
let context = SC.context sctx in let context = SC.context sctx in
if not (String_set.mem already_used unit.name) then if not (Module.Name.Set.mem already_used unit.name) then
SC.add_rule sctx SC.add_rule sctx
(Build.run ~context (Ok context.ocamldep) (Build.run ~context (Ok context.ocamldep)
[A "-modules"; Ml_kind.flag ml_kind; Dep file] [A "-modules"; Ml_kind.flag ml_kind; Dep file]
@ -137,7 +142,7 @@ let rules ~(ml_kind:Ml_kind.t) ~dir ~modules
let per_module = let per_module =
match alias_module with match alias_module with
| None -> per_module | None -> per_module
| Some m -> String_map.add per_module m.name (Build.return []) | Some m -> Module.Name.Map.add per_module m.name (Build.return [])
in in
{ Dep_graph. { Dep_graph.
dir dir

8
src/ocamldep.mli
View File

@ -1,6 +1,4 @@
(** ocamldep managenemt *) (** ocamldep management *)
open Import
module Dep_graph : sig module Dep_graph : sig
type t type t
@ -36,8 +34,8 @@ end
Return arrows that evaluate to the dependency graphs. *) Return arrows that evaluate to the dependency graphs. *)
val rules val rules
: dir:Path.t : dir:Path.t
-> modules:Module.t String_map.t -> modules:Module.t Module.Name.Map.t
-> ?already_used:String_set.t -> ?already_used:Module.Name.Set.t
-> alias_module:Module.t option -> alias_module:Module.t option
-> lib_interface_module:Module.t option -> lib_interface_module:Module.t option
-> Super_context.t -> Super_context.t

5
src/odoc.ml
View File

@ -198,7 +198,8 @@ let all_mld_files sctx ~(lib : Library.t) ~modules ~dir files =
"{1 Library %s}\n\ "{1 Library %s}\n\
This library exposes the following toplevel modules: {!modules:%s}." This library exposes the following toplevel modules: {!modules:%s}."
lib_name lib_name
(String_map.keys modules |> String.concat ~sep:" ")))) ((Module.Name.Map.keys modules :> string list)
|> String.concat ~sep:" "))))
>>> >>>
Build.write_file_dyn generated_mld); Build.write_file_dyn generated_mld);
mld mld
@ -242,7 +243,7 @@ let setup_library_rules sctx (lib : Library.t) ~dir ~scope ~modules ~mld_files
~doc_dir ~lib_unique_name (Mld m)) ~doc_dir ~lib_unique_name (Mld m))
in in
let modules_and_odoc_files = let modules_and_odoc_files =
List.map (String_map.values modules) ~f:(fun m -> List.map (Module.Name.Map.values modules) ~f:(fun m ->
compile sctx ~odoc ~dir ~obj_dir ~includes ~dep_graphs compile sctx ~odoc ~dir ~obj_dir ~includes ~dep_graphs
~doc_dir ~lib_unique_name (Module m)) ~doc_dir ~lib_unique_name (Module m))
in in

3
src/odoc.mli
View File

@ -1,6 +1,5 @@
(** Odoc rules *) (** Odoc rules *)
open Import
open Jbuild open Jbuild
val setup_library_rules val setup_library_rules
@ -8,7 +7,7 @@ val setup_library_rules
-> Library.t -> Library.t
-> dir:Path.t -> dir:Path.t
-> scope:Scope.t -> scope:Scope.t
-> modules:Module.t String_map.t -> modules:Module.t Module.Name.Map.t
-> mld_files:string list -> mld_files:string list
-> requires:(unit, Lib.t list) Build.t -> requires:(unit, Lib.t list) Build.t
-> dep_graphs:Ocamldep.Dep_graphs.t -> dep_graphs:Ocamldep.Dep_graphs.t

2
src/preprocessing.ml
View File

@ -365,5 +365,5 @@ let pp_and_lint_modules sctx ~dir ~dep_kind ~modules ~lint ~preprocess
; Ml_kind.ppx_driver_flag kind; Dep src ; Ml_kind.ppx_driver_flag kind; Dep src
]))))) ])))))
in in
String_map.map modules ~f:(fun (m : Module.t) -> Module.Name.Map.map modules ~f:(fun (m : Module.t) ->
Per_module.get preprocess m.name m) Per_module.get preprocess m.name m)

4
src/preprocessing.mli
View File

@ -8,13 +8,13 @@ val pp_and_lint_modules
: Super_context.t : Super_context.t
-> dir:Path.t -> dir:Path.t
-> dep_kind:Build.lib_dep_kind -> dep_kind:Build.lib_dep_kind
-> modules:Module.t String_map.t -> modules:Module.t Module.Name.Map.t
-> lint:Jbuild.Preprocess_map.t -> lint:Jbuild.Preprocess_map.t
-> preprocess:Jbuild.Preprocess_map.t -> preprocess:Jbuild.Preprocess_map.t
-> preprocessor_deps:(unit, Path.t list) Build.t -> preprocessor_deps:(unit, Path.t list) Build.t
-> lib_name:string option -> lib_name:string option
-> scope:Scope.t -> scope:Scope.t
-> Module.t String_map.t -> Module.t Module.Name.Map.t
(** Get a path to a cached ppx driver *) (** Get a path to a cached ppx driver *)
val get_ppx_driver val get_ppx_driver

2
src/sub_system_intf.ml
View File

@ -67,7 +67,7 @@ module Library_compilation_context = struct
; dir : Path.t ; dir : Path.t
; stanza : Jbuild.Library.t ; stanza : Jbuild.Library.t
; scope : Scope.t ; scope : Scope.t
; source_modules : Module.t String_map.t ; source_modules : Module.t Module.Name.Map.t
; compile_info : Lib.Compile.t ; compile_info : Lib.Compile.t
} }
end end

4
src/utop.ml
View File

@ -4,7 +4,7 @@ open Build.O
open! No_io open! No_io
let exe_name = "utop" let exe_name = "utop"
let main_module_name = String.capitalize exe_name let main_module_name = Module.Name.of_string exe_name
let main_module_filename = exe_name ^ ".ml" let main_module_filename = exe_name ^ ".ml"
let pp_ml fmt include_dirs = let pp_ml fmt include_dirs =
@ -51,7 +51,7 @@ let setup sctx ~dir ~(libs : Library.t list) ~scope =
| [] -> () | [] -> ()
| _ :: _ -> | _ :: _ ->
let modules = let modules =
String_map.singleton Module.Name.Map.singleton
main_module_name main_module_name
{ Module. { Module.
name = main_module_name name = main_module_name