Skip to content

Commit

Permalink
Change [chdir] impl
Browse files Browse the repository at this point in the history 
Be a bit more incremental

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>
  • Loading branch information
@rgrinberg
rgrinberg committed Mar 17, 2020
1 parent c840cbb commit 8e65040
Show file tree
Hide file tree
Showing 4 changed files with 101 additions and 95 deletions.
150 changes: 67 additions & 83 deletions src/dune/file_tree.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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) =
Expand All @@ -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
Expand Down
33 changes: 24 additions & 9 deletions src/dune/sub_dirs.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 =
Expand Down
6 changes: 5 additions & 1 deletion src/dune/sub_dirs.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
7 changes: 5 additions & 2 deletions test/blackbox-tests/test-cases/chdir-stanza/run.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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

0 comments on commit 8e65040

Please sign in to comment.