diff --git a/src/gen_rules.ml b/src/gen_rules.ml index 63fef91f..bd39bb15 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -17,11 +17,6 @@ module Gen(P : Install_rules.Params) = struct let sctx = P.sctx let ctx = SC.context sctx - let stanzas_per_dir = - List.map (SC.stanzas sctx) ~f:(fun stanzas -> - (stanzas.SC.Dir_with_jbuild.ctx_dir, stanzas)) - |> Path.Map.of_list_exn - (* +-----------------------------------------------------------------+ | Interpretation of [modules] fields | +-----------------------------------------------------------------+ *) @@ -173,176 +168,116 @@ module Gen(P : Install_rules.Params) = struct mlds (* +-----------------------------------------------------------------+ - | User rules & copy files | + | Directory contents | +-----------------------------------------------------------------+ *) - let interpret_locks ~dir ~scope locks = - List.map locks ~f:(SC.expand_vars_path sctx ~dir ~scope) + module Dir_contents : sig + type t = private + { (* Set of "text" files (.ml, .c, ...). This is + the set of source files + user generated ones. *) + text_files : String.Set.t + ; modules : Module.t Module.Name.Map.t Lazy.t + ; mlds : string String.Map.t Lazy.t + } - let user_rule (rule : Rule.t) ~dir ~scope = - let targets : SC.Action.targets = - match rule.targets with - | Infer -> Infer - | Static fns -> Static (List.map fns ~f:(Path.relative dir)) - in - SC.add_rule_get_targets sctx ~mode:rule.mode ~loc:rule.loc - ~locks:(interpret_locks ~dir ~scope rule.locks) - (SC.Deps.interpret_named sctx ~scope ~dir rule.deps - >>> - SC.Action.run - sctx - (snd rule.action) - ~loc:(fst rule.action) - ~dir - ~bindings:(Pform.Map.of_bindings rule.deps) - ~dep_kind:Required - ~targets - ~targets_dir:dir - ~scope) + val get : dir:Path.t -> t + end = struct + type t = + { text_files : String.Set.t + ; modules : Module.t Module.Name.Map.t Lazy.t + ; mlds : string String.Map.t Lazy.t + } - let copy_files_rules (def: Copy_files.t) ~src_dir ~dir ~scope = - let loc = String_with_vars.loc def.glob in - let glob_in_src = - let src_glob = SC.expand_vars_string sctx ~dir def.glob ~scope in - Path.relative src_dir src_glob ~error_loc:loc - in - (* The following condition is required for merlin to work. - Additionally, the order in which the rules are evaluated only - ensures that [sources_and_targets_known_so_far] returns the - right answer for sub-directories only. *) - if not (Path.is_descendant glob_in_src ~of_:src_dir) then - Loc.fail loc "%s is not a sub-directory of %s" - (Path.to_string_maybe_quoted glob_in_src) (Path.to_string_maybe_quoted src_dir); - let glob = Path.basename glob_in_src in - let src_in_src = Path.parent_exn glob_in_src in - let re = - match Glob_lexer.parse_string glob with - | Ok re -> - Re.compile re - | Error (_pos, msg) -> - Loc.fail (String_with_vars.loc def.glob) "invalid glob: %s" msg - in - (* add rules *) - let src_in_build = Path.append ctx.build_dir src_in_src in - let files = SC.eval_glob sctx ~dir:src_in_build re in - List.map files ~f:(fun basename -> - let file_src = Path.relative src_in_build basename in - let file_dst = Path.relative dir basename in - SC.add_rule sctx - ((if def.add_line_directive - then Build.copy_and_add_line_directive - else Build.copy) - ~src:file_src - ~dst:file_dst); - file_dst) + (* As a side-effect, setup user rules and copy_files rules. *) + let load_text_files ~dir = + match SC.stanzas_in sctx ~dir with + | None -> String.Set.empty + | Some { stanzas; src_dir; scope; _ } -> + (* Interpret a few stanzas in order to determine the list of + files generated by the user. *) + let generated_files = + List.concat_map stanzas ~f:(fun stanza -> + match (stanza : Stanza.t) with + | Menhir.T menhir -> + Menhir_rules.targets menhir + | Rule rule -> + List.map (Simple_rules.user_rule sctx rule ~dir ~scope) + ~f:Path.basename + | Copy_files def -> + List.map (Simple_rules.copy_files sctx def ~src_dir ~dir ~scope) + ~f:Path.basename + | Library { buildable; _ } | Executables { buildable; _ } -> + (* Manually add files generated by the (select ...) + dependencies *) + List.filter_map buildable.libraries ~f:(fun dep -> + match (dep : Jbuild.Lib_dep.t) with + | Direct _ -> None + | Select s -> Some s.result_fn) + | _ -> []) + |> String.Set.of_list + in + String.Set.union generated_files + (SC.source_files sctx ~src_path:src_dir) - (* +-----------------------------------------------------------------+ - | "text" file listing | - +-----------------------------------------------------------------+ *) + let extract_modules ~dir ~files = + let make_module syntax base fn = + (Module.Name.of_string base, + Module.File.make syntax (Path.relative dir fn)) + in + let impl_files, intf_files = + String.Set.to_list files + |> List.filter_partition_map ~f:(fun fn -> + (* we aren't using Filename.extension because we want to handle + filenames such as foo.cppo.ml *) + match String.lsplit2 fn ~on:'.' with + | Some (s, "ml" ) -> Left (make_module OCaml s fn) + | Some (s, "re" ) -> Left (make_module Reason s fn) + | Some (s, "mli") -> Right (make_module OCaml s fn) + | Some (s, "rei") -> Right (make_module Reason s fn) + | _ -> Skip) + in + let parse_one_set (files : (Module.Name.t * Module.File.t) list) = + match Module.Name.Map.of_list files with + | Ok x -> x + | Error (name, f1, f2) -> + let src_dir = Path.drop_build_context_exn dir in + die "Too many files for module %a in %a:\ + \n- %a\ + \n- %a" + Module.Name.pp name + Path.pp src_dir + Path.pp f1.path + Path.pp f2.path + in + let impls = parse_one_set impl_files in + let intfs = parse_one_set intf_files in + Module.Name.Map.merge impls intfs ~f:(fun name impl intf -> + Some (Module.make name ?impl ?intf)) - (* Compute the list of "text" files (.ml, .c, ...). This is the list - of source files + user generated ones. As a side-effect, setup - user rules and copy_files rules. *) - let text_files = - let cache = Hashtbl.create 32 in - fun ~dir -> - Hashtbl.find_or_add cache dir ~f:(fun dir -> - match Path.Map.find stanzas_per_dir dir with - | None -> String.Set.empty - | Some { stanzas; src_dir; scope; _ } -> - (* Interpret a few stanzas in order to determine the list of - files generated by the user. *) - let generated_files = - List.concat_map stanzas ~f:(fun stanza -> - match (stanza : Stanza.t) with - | Menhir.T menhir -> - Menhir_rules.targets menhir - | Rule rule -> - List.map (user_rule rule ~dir ~scope) ~f:Path.basename - | Copy_files def -> - List.map (copy_files_rules def ~src_dir ~dir ~scope) - ~f:Path.basename - | Library { buildable; _ } | Executables { buildable; _ } -> - (* Manually add files generated by the (select ...) - dependencies *) - List.filter_map buildable.libraries ~f:(fun dep -> - match (dep : Jbuild.Lib_dep.t) with - | Direct _ -> None - | Select s -> Some s.result_fn) - | _ -> []) - |> String.Set.of_list - in - String.Set.union generated_files - (SC.source_files sctx ~src_path:src_dir)) - - (* +-----------------------------------------------------------------+ - | Modules listing | - +-----------------------------------------------------------------+ *) - - let guess_modules ~dir ~files = - let make_module syntax base fn = - (Module.Name.of_string base, - Module.File.make syntax (Path.relative dir fn)) - in - let impl_files, intf_files = - String.Set.to_list files - |> List.filter_partition_map ~f:(fun fn -> - (* we aren't using Filename.extension because we want to handle - filenames such as foo.cppo.ml *) + let extract_mlds ~files = + String.Set.fold files ~init:String.Map.empty ~f:(fun fn acc -> match String.lsplit2 fn ~on:'.' with - | Some (s, "ml" ) -> Left (make_module OCaml s fn) - | Some (s, "re" ) -> Left (make_module Reason s fn) - | Some (s, "mli") -> Right (make_module OCaml s fn) - | Some (s, "rei") -> Right (make_module Reason s fn) - | _ -> Skip) - in - let parse_one_set (files : (Module.Name.t * Module.File.t) list) = - match Module.Name.Map.of_list files with - | Ok x -> x - | Error (name, f1, f2) -> - let src_dir = Path.drop_build_context_exn dir in - die "Too many files for module %a in %a:\ - \n- %a\ - \n- %a" - Module.Name.pp name - Path.pp src_dir - Path.pp f1.path - Path.pp f2.path - in - let impls = parse_one_set impl_files in - let intfs = parse_one_set intf_files in - Module.Name.Map.merge impls intfs ~f:(fun name impl intf -> - Some (Module.make name ?impl ?intf)) + | Some (s, "mld") -> String.Map.add acc s fn + | _ -> acc) - let guess_mlds ~files = - String.Set.to_list files - |> List.filter_map ~f:(fun fn -> - match String.lsplit2 fn ~on:'.' with - | Some (s, "mld") -> Some (s, fn) - | _ -> None) - |> String.Map.of_list_exn - - let mlds_by_dir = - let cache = Hashtbl.create 32 in - fun ~dir -> - Hashtbl.find_or_add cache dir ~f:(fun dir -> - let files = text_files ~dir in - guess_mlds ~files) + let get = + let cache = Hashtbl.create 32 in + fun ~dir -> + Hashtbl.find_or_add cache dir ~f:(fun dir -> + let files = load_text_files ~dir in + { text_files = files + ; modules = lazy (extract_modules ~dir ~files) + ; mlds = lazy (extract_mlds ~files) + }) + end let mlds_of_dir (doc : Documentation.t) ~dir = parse_mlds ~dir - ~all_mlds:(mlds_by_dir ~dir) + ~all_mlds:(Lazy.force (Dir_contents.get ~dir).mlds) ~mlds_written_by_user:doc.mld_files |> String.Map.values |> List.map ~f:(Path.relative dir) - let modules_by_dir = - let cache = Hashtbl.create 32 in - fun ~dir -> - Hashtbl.find_or_add cache dir ~f:(fun dir -> - let files = text_files ~dir in - guess_modules ~dir ~files) - type modules_by_lib = { modules : Module.t Module.Name.Map.t ; alias_module : Module.t option @@ -353,7 +288,7 @@ module Gen(P : Install_rules.Params) = struct let cache = Hashtbl.create 32 in fun (lib : Library.t) ~dir -> Hashtbl.find_or_add cache (dir, lib.name) ~f:(fun _ -> - let all_modules = modules_by_dir ~dir in + let all_modules = Lazy.force (Dir_contents.get ~dir).modules in let modules = parse_modules ~all_modules ~buildable:lib.buildable in @@ -921,44 +856,9 @@ module Gen(P : Install_rules.Params) = struct ~modules_partitioner ~scope ~compile_info ~dir_kind) (* +-----------------------------------------------------------------+ - | Aliases | + | Tests | +-----------------------------------------------------------------+ *) - let add_alias ~dir ~name ~stamp ?(locks=[]) build = - let alias = Build_system.Alias.make name ~dir in - SC.add_alias_action sctx alias ~locks ~stamp build - - let alias_rules (alias_conf : Alias_conf.t) ~dir ~scope = - let stamp = - let module S = Sexp.To_sexp in - Sexp.List - [ Sexp.unsafe_atom_of_string "user-alias" - ; Jbuild.Bindings.sexp_of_t Jbuild.Dep_conf.sexp_of_t alias_conf.deps - ; S.option Action.Unexpanded.sexp_of_t - (Option.map alias_conf.action ~f:snd) - ] - in - add_alias - ~dir - ~name:alias_conf.name - ~stamp - ~locks:(interpret_locks ~dir ~scope alias_conf.locks) - (SC.Deps.interpret_named sctx ~scope ~dir alias_conf.deps - >>> - match alias_conf.action with - | None -> Build.progn [] - | Some (loc, action) -> - SC.Action.run - sctx - action - ~loc - ~dir - ~dep_kind:Required - ~bindings:(Pform.Map.of_bindings alias_conf.deps) - ~targets:Alias - ~targets_dir:dir - ~scope) - let tests_rules (t : Tests.t) ~dir ~scope ~all_modules ~modules_partitioner ~dir_kind ~src_dir = let test_kind (loc, name) = @@ -1011,12 +911,13 @@ module Gen(P : Install_rules.Params) = struct } in match test_kind (loc, s) with | `Regular -> - alias_rules ~dir ~scope (regular_rule run_action base_alias loc) + Simple_rules.alias sctx ~dir ~scope + (regular_rule run_action base_alias loc) | `Expect diff -> let (alias, rule) = expect_rule run_action diff base_alias loc in - alias_rules ~dir ~scope alias; - ignore (user_rule ~dir ~scope rule : Path.t list)); + Simple_rules.alias sctx alias ~dir ~scope; + ignore (Simple_rules.user_rule sctx rule ~dir ~scope : Path.t list)); executables_rules t.exes ~dir ~all_modules ~scope ~dir_kind ~modules_partitioner @@ -1026,8 +927,12 @@ module Gen(P : Install_rules.Params) = struct let gen_rules { SC.Dir_with_jbuild. src_dir; ctx_dir; stanzas; scope; kind } = (* This interprets "rule" and "copy_files" stanzas. *) - let files = text_files ~dir:ctx_dir in - let all_modules = modules_by_dir ~dir:ctx_dir in + let { Dir_contents. + text_files = files + ; modules = lazy all_modules + ; mlds = _ + } = Dir_contents.get ~dir:ctx_dir + in let modules_partitioner = Modules_partitioner.create ~dir_kind:kind in let merlins = List.filter_map stanzas ~f:(fun stanza -> @@ -1040,7 +945,7 @@ module Gen(P : Install_rules.Params) = struct Some (executables_rules exes ~dir ~all_modules ~scope ~modules_partitioner ~dir_kind:kind) | Alias alias -> - alias_rules alias ~dir ~scope; + Simple_rules.alias sctx alias ~dir ~scope; None | Tests tests -> Some (tests_rules tests ~dir ~scope ~all_modules ~src_dir @@ -1096,7 +1001,7 @@ module Gen(P : Install_rules.Params) = struct | "_doc" :: rest -> Odoc.gen_rules rest ~dir | ".ppx" :: rest -> Preprocessing.gen_rules sctx rest | _ -> - match Path.Map.find stanzas_per_dir dir with + match SC.stanzas_in sctx ~dir with | Some x -> gen_rules x | None -> if components <> [] && diff --git a/src/simple_rules.ml b/src/simple_rules.ml new file mode 100644 index 00000000..96fd9fc9 --- /dev/null +++ b/src/simple_rules.ml @@ -0,0 +1,101 @@ +open Import +open Jbuild +open Build.O +open! No_io + +module SC = Super_context + +let interpret_locks sctx ~dir ~scope locks = + List.map locks ~f:(SC.expand_vars_path sctx ~dir ~scope) + +let user_rule sctx ~dir ~scope (rule : Rule.t) = + let targets : SC.Action.targets = + match rule.targets with + | Infer -> Infer + | Static fns -> Static (List.map fns ~f:(Path.relative dir)) + in + SC.add_rule_get_targets sctx ~mode:rule.mode ~loc:rule.loc + ~locks:(interpret_locks sctx ~dir ~scope rule.locks) + (SC.Deps.interpret_named sctx ~scope ~dir rule.deps + >>> + SC.Action.run + sctx + (snd rule.action) + ~loc:(fst rule.action) + ~dir + ~bindings:(Pform.Map.of_bindings rule.deps) + ~dep_kind:Required + ~targets + ~targets_dir:dir + ~scope) + +let copy_files sctx ~dir ~scope ~src_dir (def: Copy_files.t) = + let loc = String_with_vars.loc def.glob in + let glob_in_src = + let src_glob = SC.expand_vars_string sctx ~dir def.glob ~scope in + Path.relative src_dir src_glob ~error_loc:loc + in + (* The following condition is required for merlin to work. + Additionally, the order in which the rules are evaluated only + ensures that [sources_and_targets_known_so_far] returns the + right answer for sub-directories only. *) + if not (Path.is_descendant glob_in_src ~of_:src_dir) then + Loc.fail loc "%s is not a sub-directory of %s" + (Path.to_string_maybe_quoted glob_in_src) (Path.to_string_maybe_quoted src_dir); + let glob = Path.basename glob_in_src in + let src_in_src = Path.parent_exn glob_in_src in + let re = + match Glob_lexer.parse_string glob with + | Ok re -> + Re.compile re + | Error (_pos, msg) -> + Loc.fail (String_with_vars.loc def.glob) "invalid glob: %s" msg + in + (* add rules *) + let src_in_build = Path.append (SC.context sctx).build_dir src_in_src in + let files = SC.eval_glob sctx ~dir:src_in_build re in + List.map files ~f:(fun basename -> + let file_src = Path.relative src_in_build basename in + let file_dst = Path.relative dir basename in + SC.add_rule sctx + ((if def.add_line_directive + then Build.copy_and_add_line_directive + else Build.copy) + ~src:file_src + ~dst:file_dst); + file_dst) + +let add_alias sctx ~dir ~name ~stamp ?(locks=[]) build = + let alias = Build_system.Alias.make name ~dir in + SC.add_alias_action sctx alias ~locks ~stamp build + +let alias sctx ~dir ~scope (alias_conf : Alias_conf.t) = + let stamp = + let module S = Sexp.To_sexp in + Sexp.List + [ Sexp.unsafe_atom_of_string "user-alias" + ; Jbuild.Bindings.sexp_of_t Jbuild.Dep_conf.sexp_of_t alias_conf.deps + ; S.option Action.Unexpanded.sexp_of_t + (Option.map alias_conf.action ~f:snd) + ] + in + add_alias sctx + ~dir + ~name:alias_conf.name + ~stamp + ~locks:(interpret_locks sctx ~dir ~scope alias_conf.locks) + (SC.Deps.interpret_named sctx ~scope ~dir alias_conf.deps + >>> + match alias_conf.action with + | None -> Build.progn [] + | Some (loc, action) -> + SC.Action.run + sctx + action + ~loc + ~dir + ~dep_kind:Required + ~bindings:(Pform.Map.of_bindings alias_conf.deps) + ~targets:Alias + ~targets_dir:dir + ~scope) diff --git a/src/simple_rules.mli b/src/simple_rules.mli new file mode 100644 index 00000000..1a40a90a --- /dev/null +++ b/src/simple_rules.mli @@ -0,0 +1,29 @@ +(** Simple rules: user, copy_files, alias *) + +open Import +open Jbuild + +(** Interpret a [(rule ...)] stanza and return the targets it produces. *) +val user_rule + : Super_context.t + -> dir:Path.t + -> scope:Scope.t + -> Rule.t + -> Path.t list + +(** Interpret a [(copy_files ...)] stanza and return the targets it produces. *) +val copy_files + : Super_context.t + -> dir:Path.t + -> scope:Scope.t + -> src_dir:Path.t + -> Copy_files.t + -> Path.t list + +(** Interpret an [(alias ...)] stanza. *) +val alias + : Super_context.t + -> dir:Path.t + -> scope:Scope.t + -> Alias_conf.t + -> unit diff --git a/src/super_context.ml b/src/super_context.ml index c3459b86..973c4bfc 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -40,6 +40,7 @@ type t = ; public_libs : Lib.DB.t ; installed_libs : Lib.DB.t ; stanzas : Dir_with_jbuild.t list + ; stanzas_per_dir : Dir_with_jbuild.t Path.Map.t ; packages : Package.t Package.Name.Map.t ; file_tree : File_tree.t ; artifacts : Artifacts.t @@ -55,6 +56,7 @@ type t = let context t = t.context let stanzas t = t.stanzas +let stanzas_in t ~dir = Path.Map.find t.stanzas_per_dir dir let packages t = t.packages let libs_by_package t = t.libs_by_package let artifacts t = t.artifacts @@ -248,6 +250,11 @@ let create ; kind }) in + let stanzas_per_dir = + List.map stanzas ~f:(fun stanzas -> + (stanzas.Dir_with_jbuild.ctx_dir, stanzas)) + |> Path.Map.of_list_exn + in let stanzas_to_consider_for_install = if not external_lib_deps_mode then List.concat_map stanzas ~f:(fun { ctx_dir; stanzas; scope; kind; _ } -> @@ -305,6 +312,7 @@ let create ; public_libs ; installed_libs ; stanzas + ; stanzas_per_dir ; packages ; file_tree ; stanzas_to_consider_for_install diff --git a/src/super_context.mli b/src/super_context.mli index 40bf02d8..02e630f6 100644 --- a/src/super_context.mli +++ b/src/super_context.mli @@ -43,6 +43,7 @@ val create val context : t -> Context.t val stanzas : t -> Dir_with_jbuild.t list +val stanzas_in : t -> dir:Path.t -> Dir_with_jbuild.t option val packages : t -> Package.t Package.Name.Map.t val libs_by_package : t -> (Package.t * Lib.Set.t) Package.Name.Map.t val file_tree : t -> File_tree.t