From 5974be475aee648257b77f2f55b52071f001a8a2 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Thu, 12 Jul 2018 17:03:11 +0100 Subject: [PATCH] Refactor a bit the functions computing directories contents Signed-off-by: Jeremie Dimino --- src/gen_rules.ml | 199 ++++++++++++++++++++++++----------------------- 1 file changed, 103 insertions(+), 96 deletions(-) diff --git a/src/gen_rules.ml b/src/gen_rules.ml index 63fef91f..4ff3e069 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -237,112 +237,115 @@ module Gen(P : Install_rules.Params) = struct file_dst) (* +-----------------------------------------------------------------+ - | "text" file listing | + | Directory contents | +-----------------------------------------------------------------+ *) - (* 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)) + module Dir_contents : sig + type t = + { (* 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 + } - (* +-----------------------------------------------------------------+ - | Modules listing | - +-----------------------------------------------------------------+ *) + 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 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 *) + (* As a side-effect, setup user rules and copy_files rules. *) + let load_text_files ~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) + + 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)) + + 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 +356,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 @@ -1026,8 +1029,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 + ; _ + } = 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 ->