From 8e6504073209d741d7fb497493de498c935b9d0c Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 17 Mar 2020 13:12:14 +0100 Subject: [PATCH] Change [chdir] impl Be a bit more incremental Signed-off-by: Rudi Grinberg --- src/dune/file_tree.ml | 150 ++++++++---------- src/dune/sub_dirs.ml | 33 ++-- src/dune/sub_dirs.mli | 6 +- .../test-cases/chdir-stanza/run.t | 7 +- 4 files changed, 101 insertions(+), 95 deletions(-) diff --git a/src/dune/file_tree.ml b/src/dune/file_tree.ml index 2b48cc85e02e..6439a47015e6 100644 --- a/src/dune/file_tree.ml +++ b/src/dune/file_tree.ml @@ -62,49 +62,30 @@ module Dune_file = struct | Plain x -> x.path | Ocaml_script p -> p - let load_plain file sexps ~parents ~project = + let load_plain file sexps ~parent ~project = let decoder = Dune_project.set_parsing_context project Sub_dirs.decode in - let for_subdirs = - Dune_lang.Decoder.parse decoder Univ_map.empty - (Dune_lang.Ast.List (Loc.none, sexps)) - in - let contents = - let { Sub_dirs.Dir_map.sexps; subdir_status } = - Sub_dirs.Dir_map.root for_subdirs - in - let sexps, subdir_status = - List.fold_left parents - ~init:([ sexps ], subdir_status) - ~f: - (fun (acc_sexps, acc_subdir_status) - { Sub_dirs.Dir_map.sexps; subdir_status } -> - let acc_subdir_status = - Sub_dirs.Status.Map.merge acc_subdir_status subdir_status - ~f:(fun acc s -> - match (acc, s) with - | acc, None - | None, acc -> - acc - | Some (loc, _), Some (loc2, _) -> - User_error.raise ~loc - [ Pp.text "This stanza stanza was already specified at:" - ; Pp.verbatim (Loc.to_file_colon_line loc2) - ]) - in - let acc_sexps = sexps :: acc_sexps in - (acc_sexps, acc_subdir_status)) + let active = + let parsed = + Dune_lang.Decoder.parse decoder Univ_map.empty + (Dune_lang.Ast.List (Loc.none, sexps)) in - { Sub_dirs.Dir_map.sexps = List.concat sexps; subdir_status } + match parent with + | None -> parsed + | Some parent -> Sub_dirs.Dir_map.merge parsed parent in - { Plain.path = file; contents; for_subdirs } + let contents = Sub_dirs.Dir_map.root active in + { Plain.path = file; contents; for_subdirs = active } - let load file ~parents ~project = - Io.with_lexbuf_from_file (Path.source file) ~f:(fun lb -> - if Dune_lexer.is_script lb then - Ocaml_script file - else - let sexps = Dune_lang.Parser.parse lb ~mode:Many in - Plain (load_plain file sexps ~parents ~project)) + let load file ~file_exists ~parent ~project = + match file_exists with + | false -> Plain (load_plain file [] ~parent ~project) + | true -> + Io.with_lexbuf_from_file (Path.source file) ~f:(fun lb -> + if Dune_lexer.is_script lb then + Ocaml_script file + else + let sexps = Dune_lang.Parser.parse lb ~mode:Many in + Plain (load_plain file sexps ~parent ~project)) end module Readdir : sig @@ -357,16 +338,19 @@ end = struct dirs_visited_acc else let new_dirs_visited = - File.Map.update dirs_visited file ~f:(function - | None -> Some path - | Some first_path -> - User_error.raise - [ Pp.textf - "Path %s has already been scanned. Cannot scan it \ - again through symlink %s" - (Path.Source.to_string_maybe_quoted first_path) - (Path.Source.to_string_maybe_quoted path) - ]) + match file with + | None -> dirs_visited + | Some file -> + File.Map.update dirs_visited file ~f:(function + | None -> Some path + | Some first_path -> + User_error.raise + [ Pp.textf + "Path %s has already been scanned. Cannot scan \ + it again through symlink %s" + (Path.Source.to_string_maybe_quoted first_path) + (Path.Source.to_string_maybe_quoted path) + ]) in String.Map.add_exn dirs_visited_acc fn new_dirs_visited in @@ -396,41 +380,30 @@ end = struct "Note: You can use \"dune upgrade\" to convert your project to \ dune." ] - else if not (String.Set.mem files Dune_file.fname) then - None - else ( - ignore - ( Dune_project.ensure_project_file_exists project - : Dune_project.created_or_already_exist ); - let file = Path.Source.relative path Dune_file.fname in - let parents = - let desc of_ = Path.Source.descendant path ~of_ in - let rec loop acc path = - match find_dir path with - | None -> parent acc path - | Some d -> ( - match d.contents.dune_file with - | None - | Some (Ocaml_script _) -> - parent acc path - | Some (Plain dune_file) -> ( - let desc = - match desc path with - | None -> assert false - | Some d -> d - in - match Sub_dirs.Dir_map.descend dune_file.for_subdirs desc with - | None -> parent acc path - | Some per_dir -> parent (per_dir :: acc) path ) ) - and parent acc dir = - match Path.Source.parent dir with - | None -> acc - | Some d -> loop acc d - in - parent [] path + else + let file_exists = String.Set.mem files Dune_file.fname in + let parent = + let open Option.O in + let* parent = Path.Source.parent path in + let* parent = find_dir parent in + match parent.contents.dune_file with + | None + | Some (Ocaml_script _) -> + None (* wrong but easy *) + | Some (Plain dune_file) -> + let dir_basename = Path.Source.basename path in + Sub_dirs.Dir_map.descend dune_file.for_subdirs dir_basename in - Some (Dune_file.load file ~project ~parents) - ) + let dune_file_absent = (not file_exists) && Option.is_none parent in + if dune_file_absent then + None + else ( + ignore + ( Dune_project.ensure_project_file_exists project + : Dune_project.created_or_already_exist ); + let file = Path.Source.relative path Dune_file.fname in + Some (Dune_file.load file ~file_exists ~project ~parent) + ) let contents { Readdir.dirs; files } ~dirs_visited ~project ~path ~(dir_status : Sub_dirs.Status.t) = @@ -441,6 +414,17 @@ end = struct let dune_file = dune_file ~dir_status ~recognize_jbuilder_projects ~files ~project ~path in + let dirs = List.map dirs ~f:(fun (n, s, f) -> (n, s, Some f)) in + let dirs = + match dune_file with + | None + | Some (Ocaml_script _) -> + dirs + | Some (Plain dune_file) -> + dirs + @ ( Sub_dirs.Dir_map.sub_dirs dune_file.for_subdirs + |> List.map ~f:(fun s -> (s, Path.Source.relative path s, None)) ) + in let sub_dirs = Dune_file.sub_dirs dune_file in let dirs_visited, sub_dirs = get_sub_dirs ~dirs_visited ~dirs ~sub_dirs ~dir_status diff --git a/src/dune/sub_dirs.ml b/src/dune/sub_dirs.ml index e9a3d9d0c97a..9f2f43c40d99 100644 --- a/src/dune/sub_dirs.ml +++ b/src/dune/sub_dirs.ml @@ -145,16 +145,31 @@ module Dir_map = struct let root t = t.data - let descend t (p : Path.Source.t) = - let components = Path.Source.explode p in - let rec loop t = function - | [] -> Some t.data - | x :: xs -> - let open Option.O in - let* next = String.Map.find t.nodes x in - loop next xs + let descend t (p : string) = String.Map.find t.nodes p + + let sub_dirs t = String.Map.keys t.nodes + + let merge_data d1 d2 = + { sexps = d1.sexps @ d2.sexps + ; subdir_status = + Status.Map.merge d1.subdir_status d2.subdir_status ~f:(fun l r -> + match (l, r) with + | acc, None + | None, acc -> + acc + | Some (loc, _), Some (loc2, _) -> + User_error.raise ~loc + [ Pp.text "This stanza stanza was already specified at:" + ; Pp.verbatim (Loc.to_file_colon_line loc2) + ]) + } + + let rec merge t1 t2 : t = + let data = merge_data t1.data t2.data in + let nodes = + String.Map.union t1.nodes t2.nodes ~f:(fun _ l r -> Some (merge l r)) in - loop t components + { data; nodes } end let strict_subdir field_name = diff --git a/src/dune/sub_dirs.mli b/src/dune/sub_dirs.mli index 279913c554bd..eb10010b98ba 100644 --- a/src/dune/sub_dirs.mli +++ b/src/dune/sub_dirs.mli @@ -60,7 +60,11 @@ module Dir_map : sig ; subdir_status : subdir_stanzas } - val descend : t -> Path.Source.t -> per_dir option + val descend : t -> string -> t option + + val sub_dirs : t -> string list + + val merge : t -> t -> t val root : t -> per_dir end diff --git a/test/blackbox-tests/test-cases/chdir-stanza/run.t b/test/blackbox-tests/test-cases/chdir-stanza/run.t index 36231649e821..4425e3d82b9a 100644 --- a/test/blackbox-tests/test-cases/chdir-stanza/run.t +++ b/test/blackbox-tests/test-cases/chdir-stanza/run.t @@ -5,8 +5,11 @@ > bar > (rule (with-stdout-to foo.txt (echo "bar")))) > EOF - $ mkdir bar - $ touch bar/dune $ dune build ./foo.txt ./bar/foo.txt + Warning: Unable to read directory bar. Ignoring. + Remove this message by ignoring by adding: + (dirs \ bar) + to the dune file: dune + Reason: No such file or directory $ cat _build/default/foo.txt bar