From 9a0c822e23ac3ac1849e7ae6ed4e03996b01b2f6 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Mon, 14 Oct 2019 23:35:08 +0900 Subject: [PATCH 1/5] Introduce Alias.Name This introduces a type for alias names. Signed-off-by: Rudi Grinberg --- bin/alias.ml | 6 ++--- bin/alias.mli | 8 ++++-- bin/arg.ml | 22 +++++++++++---- bin/arg.mli | 4 +-- bin/common.ml | 6 +++-- bin/main.ml | 13 +++------ bin/target.ml | 2 +- src/dune/alias.ml | 56 ++++++++++++++++++++++++++++++++++++--- src/dune/alias.mli | 32 +++++++++++++++++++--- src/dune/build_system.ml | 21 ++++++++------- src/dune/build_system.mli | 10 +++++-- src/dune/dune_file.ml | 11 ++------ src/dune/dune_file.mli | 2 +- src/dune/odoc.ml | 2 +- src/dune/rules.ml | 11 ++++---- src/dune/rules.mli | 2 +- src/dune/test_rules.ml | 2 +- 17 files changed, 150 insertions(+), 60 deletions(-) diff --git a/bin/alias.ml b/bin/alias.ml index 92771ea25bb..643e64dbfd0 100644 --- a/bin/alias.ml +++ b/bin/alias.ml @@ -1,7 +1,7 @@ open Stdune type t = - { name : string + { name : Dune.Alias.Name.t ; recursive : bool ; dir : Path.Source.t ; contexts : Dune.Context.t list @@ -18,7 +18,7 @@ let to_log_string { name; recursive; dir; contexts = _ } = else "@@" ) (Path.Source.to_string_maybe_quoted dir) - name + (Dune.Alias.Name.to_string name) let in_dir ~name ~recursive ~contexts dir = let checked = Util.check_path contexts dir in @@ -50,5 +50,5 @@ let of_string common ~recursive s ~contexts = ] else let dir = Path.parent_exn path in - let name = Path.basename path in + let name = Dune.Alias.Name.of_string (Path.basename path) in in_dir ~name ~recursive ~contexts dir diff --git a/bin/alias.mli b/bin/alias.mli index 85a9d7582da..74fa0bf1baf 100644 --- a/bin/alias.mli +++ b/bin/alias.mli @@ -1,14 +1,18 @@ open Stdune type t = private - { name : string + { name : Dune.Alias.Name.t ; recursive : bool ; dir : Path.Source.t ; contexts : Dune.Context.t list } val in_dir : - name:string -> recursive:bool -> contexts:Dune.Context.t list -> Path.t -> t + name:Dune.Alias.Name.t + -> recursive:bool + -> contexts:Dune.Context.t list + -> Path.t + -> t val of_string : Common.t -> recursive:bool -> string -> contexts:Dune.Context.t list -> t diff --git a/bin/arg.ml b/bin/arg.ml index d4bd558ecda..18de3286fcb 100644 --- a/bin/arg.ml +++ b/bin/arg.ml @@ -29,9 +29,17 @@ module Dep = struct let file s = Dep_conf.File (String_with_vars.make_text Loc.none s) - let alias s = Dep_conf.Alias (String_with_vars.make_text Loc.none s) + let make_alias_sw ~dir s = + let path = + Dune.Alias.Name.to_string s + |> Stdune.Path.Local.relative dir + |> Stdune.Path.Local.to_string + in + String_with_vars.make_text Loc.none path + + let alias ~dir s = Dep_conf.Alias (make_alias_sw ~dir s) - let alias_rec s = Dep_conf.Alias_rec (String_with_vars.make_text Loc.none s) + let alias_rec ~dir s = Dep_conf.Alias_rec (make_alias_sw ~dir s) let parse_alias s = if not (String.is_prefix s ~prefix:"@") then @@ -44,15 +52,19 @@ module Dep = struct (1, true) in let s = String.drop s pos in - Some (recursive, s) + let dir, alias = + let path = Stdune.Path.Local.of_string s in + Dune.Alias.Name.parse_local_path (Loc.none, path) + in + Some (recursive, dir, alias) let dep_parser = Dune_lang.Syntax.set Stanza.syntax Stanza.latest_version Dep_conf.decode let parser s = match parse_alias s with - | Some (true, s) -> `Ok (alias_rec s) - | Some (false, s) -> `Ok (alias s) + | Some (true, dir, name) -> `Ok (alias_rec ~dir name) + | Some (false, dir, name) -> `Ok (alias ~dir name) | None -> ( match Dune_lang.Decoder.parse dep_parser Univ_map.empty diff --git a/bin/arg.mli b/bin/arg.mli index b9228b24640..b88962ecfb1 100644 --- a/bin/arg.mli +++ b/bin/arg.mli @@ -18,9 +18,9 @@ module Dep : sig val file : string -> t - val alias : string -> t + val alias : dir:Stdune.Path.Local.t -> Dune.Alias.Name.t -> t - val alias_rec : string -> t + val alias_rec : dir:Stdune.Path.Local.t -> Dune.Alias.Name.t -> t val to_string_maybe_quoted : t -> string end diff --git a/bin/common.ml b/bin/common.ml index 8c79643037b..b4601276f0a 100644 --- a/bin/common.ml +++ b/bin/common.ml @@ -248,7 +248,8 @@ module Options_implied_by_dash_p = struct and+ default_target = Arg.( value - & opt dep (Dep.alias "default") + & opt dep + (Dep.alias ~dir:Stdune.Path.Local.root Dune.Alias.Name.default) & info [ "default-target" ] ~docs ~docv:"TARGET" ~doc: {|Set the default target that when none is specified to @@ -295,7 +296,8 @@ module Options_implied_by_dash_p = struct ; ignore_promoted_rules = true ; config_file = No_config ; profile = Some Profile.Release - ; default_target = Arg.Dep.alias_rec "install" + ; default_target = + Arg.Dep.alias_rec ~dir:Path.Local.root Dune.Alias.Name.install ; always_show_command_line = true ; promote_install_files = true } diff --git a/bin/main.ml b/bin/main.ml index 202233c92a9..c4d9096aa21 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -63,20 +63,13 @@ let runtest = Common.set_common common ~targets: (List.map dirs ~f:(fun s -> - let prefix = - match s with - | "" - | "." -> - "" - | dir when dir.[String.length dir - 1] = '/' -> dir - | dir -> dir ^ "/" - in - Arg.Dep.alias_rec (prefix ^ "runtest"))); + let dir = Path.Local.of_string s in + Arg.Dep.alias_rec ~dir Dune.Alias.Name.runtest)); let targets (setup : Main.build_system) = List.map dirs ~f:(fun dir -> let dir = Path.(relative root) (Common.prefix_target common dir) in Target.Alias - (Alias.in_dir ~name:"runtest" ~recursive:true + (Alias.in_dir ~name:Dune.Alias.Name.runtest ~recursive:true ~contexts:setup.workspace.contexts dir)) in run_build_command ~common ~targets diff --git a/bin/target.ml b/bin/target.ml index ba778dc4e12..5993768d29b 100644 --- a/bin/target.ml +++ b/bin/target.ml @@ -64,7 +64,7 @@ let resolve_path path ~(setup : Dune.Main.build_system) = if Dune.File_tree.dir_exists src then Some [ Alias - (Alias.in_dir ~name:"default" ~recursive:true + (Alias.in_dir ~name:Dune.Alias.Name.default ~recursive:true ~contexts:setup.workspace.contexts path) ] else diff --git a/src/dune/alias.ml b/src/dune/alias.ml index b551b466a65..3ee009e429d 100644 --- a/src/dune/alias.ml +++ b/src/dune/alias.ml @@ -1,6 +1,56 @@ open! Stdune open Import +module Name = struct + type t = string + + let of_string_opt s = + if Filename.basename s <> s then + None + else + Some s + + let invalid_alias = Pp.textf "%S is not a valid alias name" + + let parse_string_exn (loc, s) = + match of_string_opt s with + | None -> User_error.raise ~loc [ invalid_alias s ] + | Some s -> s + + let decode = + let open Dune_lang.Decoder in + plain_string (fun ~loc s -> parse_string_exn (loc, s)) + + let of_string s = + match of_string_opt s with + | Some s -> s + | None -> + Code_error.raise "invalid alias name" [ ("s", Dyn.Encoder.string s) ] + + let to_string s = s + + let default = "default" + + let runtest = "runtest" + + let install = "install" + + let all = "all" + + let to_dyn = String.to_dyn + + module Map = String.Map + + let parse_local_path (loc, p) = + match Path.Local.parent p with + | Some dir -> (dir, Path.Local.basename p) + | None -> + User_error.raise ~loc + [ Pp.textf "Invalid alias path: %S" + (Path.Local.to_string_maybe_quoted p) + ] +end + module T : sig type t = private { dir : Path.Build.t @@ -85,11 +135,11 @@ let make_standard name = Table.add_exn standard_aliases name (); make name -let default = make_standard "default" +let default = make_standard Name.default -let runtest = make_standard "runtest" +let runtest = make_standard Name.runtest -let install = make_standard "install" +let install = make_standard Name.install let doc = make_standard "doc" diff --git a/src/dune/alias.mli b/src/dune/alias.mli index 64ae4e06319..2e175459162 100644 --- a/src/dune/alias.mli +++ b/src/dune/alias.mli @@ -1,5 +1,31 @@ open Stdune +module Name : sig + type t + + val decode : t Dune_lang.Decoder.t + + val of_string : string -> t + + val parse_string_exn : Loc.t * string -> t + + val to_string : t -> string + + val to_dyn : t -> Dyn.t + + val default : t + + val runtest : t + + val install : t + + val all : t + + val parse_local_path : Loc.t * Path.Local.t -> Path.Local.t * t + + module Map : Map.S with type key = t +end + type t val equal : t -> t -> bool @@ -8,12 +34,12 @@ val hash : t -> int val compare : t -> t -> Ordering.t -val make : string -> dir:Path.Build.t -> t +val make : Name.t -> dir:Path.Build.t -> t (** The following always holds: {[ make (name t) ~dir:(dir t) = t ]} *) -val name : t -> string +val name : t -> Name.t val dir : t -> Path.Build.t @@ -52,7 +78,7 @@ val stamp_file : t -> Path.Build.t val find_dir_specified_on_command_line : dir:Path.Source.t -> File_tree.Dir.t -val is_standard : string -> bool +val is_standard : Name.t -> bool val suffix : string diff --git a/src/dune/build_system.ml b/src/dune/build_system.ml index 1698ba48b6a..25ef4ee0fc7 100644 --- a/src/dune/build_system.ml +++ b/src/dune/build_system.ml @@ -226,7 +226,7 @@ module Alias0 = struct User_error.raise ~loc [ Pp.text "This alias is empty." ; Pp.textf "Alias %S is not defined in %s or any of its descendants." - name + (Alias.Name.to_string name) (Path.Source.to_string_maybe_quoted src_dir) ] @@ -242,14 +242,15 @@ module Alias0 = struct let is_empty = List.for_all is_empty_list ~f:Fn.id in if is_empty && not (is_standard name) then User_error.raise - [ Pp.textf "Alias %S specified on the command line is empty." name + [ Pp.textf "Alias %S specified on the command line is empty." + (Alias.Name.to_string name) ; Pp.textf "It is not defined in %s or any of its descendants." (Path.Source.to_string_maybe_quoted src_dir) ] let package_install ~(context : Context.t) ~pkg = make - (sprintf ".%s-files" (Package.Name.to_string pkg)) + (Alias.Name.of_string (sprintf ".%s-files" (Package.Name.to_string pkg))) ~dir:context.build_dir end @@ -722,7 +723,7 @@ end = struct let open Build.O in let aliases = collected.aliases in let aliases = - if String.Map.mem aliases "default" then + if Alias.Name.Map.mem aliases Alias.Name.default then aliases else match Path.Build.extract_build_context_dir dir with @@ -736,11 +737,11 @@ end = struct File_tree.Dir.project dir |> Dune_project.dune_version in if dune_version >= (2, 0) then - "all" + Alias.Name.all else - "install" + Alias.Name.install in - String.Map.set aliases "default" + Alias.Name.Map.set aliases Alias.Name.default { deps = Path.Set.empty ; dyn_deps = (let+ _ = @@ -751,12 +752,14 @@ end = struct ; actions = Appendable_list.empty } ) in - String.Map.foldi aliases ~init:[] + Alias.Name.Map.foldi aliases ~init:[] ~f:(fun name { Rules.Dir_rules.Alias_spec.deps; dyn_deps; actions } rules -> - let base_path = Path.Build.relative alias_dir name in + let base_path = + Path.Build.relative alias_dir (Alias.Name.to_string name) + in let rules, action_stamp_files = List.fold_left (Appendable_list.to_list actions) ~init:(rules, Path.Set.empty) diff --git a/src/dune/build_system.mli b/src/dune/build_system.mli index 9f437a32ca4..9ad3034cd06 100644 --- a/src/dune/build_system.mli +++ b/src/dune/build_system.mli @@ -103,14 +103,20 @@ module Alias : sig (** Implements [@@alias] on the command line *) val dep_multi_contexts : - dir:Path.Source.t -> name:string -> contexts:string list -> unit Build.t + dir:Path.Source.t + -> name:Alias.Name.t + -> contexts:string list + -> unit Build.t (** Implements [(alias_rec ...)] in dependency specification *) val dep_rec : t -> loc:Loc.t -> unit Build.t (** Implements [@alias] on the command line *) val dep_rec_multi_contexts : - dir:Path.Source.t -> name:string -> contexts:string list -> unit Build.t + dir:Path.Source.t + -> name:Alias.Name.t + -> contexts:string list + -> unit Build.t end (** {1 Building} *) diff --git a/src/dune/dune_file.ml b/src/dune/dune_file.ml index 55437841b7e..2ab84971fd5 100644 --- a/src/dune/dune_file.ml +++ b/src/dune/dune_file.ml @@ -2029,7 +2029,7 @@ end module Alias_conf = struct type t = - { name : string + { name : Alias.Name.t ; deps : Dep_conf.t Bindings.t ; action : (Loc.t * Action_dune_lang.t) option ; locks : String_with_vars.t list @@ -2038,16 +2038,9 @@ module Alias_conf = struct ; loc : Loc.t } - let alias_name = - plain_string (fun ~loc s -> - if Filename.basename s <> s then - User_error.raise ~loc [ Pp.textf "%S is not a valid alias name" s ] - else - s) - let decode = fields - (let+ name = field "name" alias_name + (let+ name = field "name" Alias.Name.decode and+ loc = loc and+ package = field_o "package" Pkg.decode and+ action = field_o "action" (located Action_dune_lang.decode) diff --git a/src/dune/dune_file.mli b/src/dune/dune_file.mli index 7f354d588b2..c56601c0e2e 100644 --- a/src/dune/dune_file.mli +++ b/src/dune/dune_file.mli @@ -415,7 +415,7 @@ end module Alias_conf : sig type t = - { name : string + { name : Alias.Name.t ; deps : Dep_conf.t Bindings.t ; action : (Loc.t * Action_dune_lang.t) option ; locks : String_with_vars.t list diff --git a/src/dune/odoc.ml b/src/dune/odoc.ml index 71aa94e6e0c..ce6a759fe3a 100644 --- a/src/dune/odoc.ml +++ b/src/dune/odoc.ml @@ -93,7 +93,7 @@ end module Dep = struct let html_alias ctx m = Alias.doc ~dir:(Paths.html ctx m) - let alias = Alias.make ".odoc-all" + let alias = Alias.make (Alias.Name.of_string ".odoc-all") let deps ctx pkg requires = Build.of_result_map requires ~f:(fun libs -> diff --git a/src/dune/rules.ml b/src/dune/rules.ml index 62c8b279617..d50e76fd0a7 100644 --- a/src/dune/rules.ml +++ b/src/dune/rules.ml @@ -37,7 +37,7 @@ module Dir_rules = struct end type alias = - { name : string + { name : Alias.Name.t ; spec : Alias_spec.t } @@ -52,13 +52,14 @@ module Dir_rules = struct Dyn.Variant ("Rule", [ Record [ ("targets", Path.Build.Set.to_dyn rule.targets) ] ]) | Alias alias -> - Dyn.Variant ("Alias", [ Record [ ("name", Dyn.String alias.name) ] ]) + Dyn.Variant + ("Alias", [ Record [ ("name", Alias.Name.to_dyn alias.name) ] ]) let to_dyn t = Dyn.Encoder.(list data_to_dyn) (Id.Map.values t) type ready = { rules : Rule.t list - ; aliases : Alias_spec.t String.Map.t + ; aliases : Alias_spec.t Alias.Name.Map.t } let consume t = @@ -69,11 +70,11 @@ module Dir_rules = struct | Alias _ -> None) in let aliases = - String.Map.of_list_multi + Alias.Name.Map.of_list_multi (List.filter_map data ~f:(function | Rule _ -> None | Alias { name; spec } -> Some (name, spec))) - |> String.Map.map ~f:(fun specs -> + |> Alias.Name.Map.map ~f:(fun specs -> List.fold_left specs ~init:Alias_spec.empty ~f:Alias_spec.union) in { rules; aliases } diff --git a/src/dune/rules.mli b/src/dune/rules.mli index 7de75ae01bd..8bbc52326b3 100644 --- a/src/dune/rules.mli +++ b/src/dune/rules.mli @@ -30,7 +30,7 @@ module Dir_rules : sig (** A ready to process view of the rules of a directory *) type ready = { rules : Rule.t list - ; aliases : Alias_spec.t String.Map.t + ; aliases : Alias_spec.t Alias.Name.Map.t } val consume : t -> ready diff --git a/src/dune/test_rules.ml b/src/dune/test_rules.ml index 7ce574df1de..f89bf0882a1 100644 --- a/src/dune/test_rules.ml +++ b/src/dune/test_rules.ml @@ -34,7 +34,7 @@ let rules (t : Dune_file.Tests.t) ~sctx ~dir ~scope ~expander ~dir_contents = in let add_alias ~loc ~action ~locks = let alias = - { Dune_file.Alias_conf.name = "runtest" + { Dune_file.Alias_conf.name = Alias.Name.runtest ; locks ; package = t.package ; deps = t.deps From 9bbc073d71d9e0784b69d529add3fb93c719ab46 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 15 Oct 2019 00:16:21 +0900 Subject: [PATCH 2/5] Validate alias names more strictly For >= 2.0 Signed-off-by: Rudi Grinberg --- src/dune/alias.ml | 27 +++++++++++++++++++++------ 1 file changed, 21 insertions(+), 6 deletions(-) diff --git a/src/dune/alias.ml b/src/dune/alias.ml index 3ee009e429d..c3f9024c7ec 100644 --- a/src/dune/alias.ml +++ b/src/dune/alias.ml @@ -4,22 +4,37 @@ open Import module Name = struct type t = string - let of_string_opt s = - if Filename.basename s <> s then + let of_string_opt_loose s = Option.some_if (Filename.basename s = s) s + + let of_string_opt = function + (* The [""] case is caught by of_string_opt_loose. But there's no harm in + being more explicit about it *) + | "" + | "." + | "/" + | ".." -> None - else - Some s + | s -> of_string_opt_loose s let invalid_alias = Pp.textf "%S is not a valid alias name" - let parse_string_exn (loc, s) = + let parse_string_exn ~syntax (loc, s) = + let of_string_opt = + if syntax >= (2, 0) then + of_string_opt + else + of_string_opt_loose + in match of_string_opt s with | None -> User_error.raise ~loc [ invalid_alias s ] | Some s -> s let decode = let open Dune_lang.Decoder in - plain_string (fun ~loc s -> parse_string_exn (loc, s)) + let* syntax = Dune_lang.Syntax.get_exn Stanza.syntax in + plain_string (fun ~loc s -> parse_string_exn ~syntax (loc, s)) + + let parse_string_exn = parse_string_exn ~syntax:Stanza.latest_version let of_string s = match of_string_opt s with From 13d18ce0fdb37858af9272674677a967643f02df Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 15 Oct 2019 11:32:13 +0900 Subject: [PATCH 3/5] Make Alias.Name.t abstract in Alias There were some implicit conversions between strings and alias names that weren't completely correct. Signed-off-by: Rudi Grinberg --- src/dune/alias.ml | 77 +++++++++++++++++++++++++++++++++-------------- 1 file changed, 54 insertions(+), 23 deletions(-) diff --git a/src/dune/alias.ml b/src/dune/alias.ml index c3f9024c7ec..f3f83217227 100644 --- a/src/dune/alias.ml +++ b/src/dune/alias.ml @@ -1,8 +1,38 @@ open! Stdune open Import -module Name = struct - type t = string +module Name : sig + type t + + include Dune_lang.Conv.S with type t := t + + val equal : t -> t -> bool + + val hash : t -> int + + val compare : t -> t -> Ordering.t + + val of_string : string -> t + + val parse_string_exn : Loc.t * string -> t + + val to_string : t -> string + + val to_dyn : t -> Dyn.t + + val default : t + + val runtest : t + + val install : t + + val all : t + + val parse_local_path : Loc.t * Path.Local.t -> Path.Local.t * t + + module Map : Map.S with type key = t +end = struct + include String let of_string_opt_loose s = Option.some_if (Filename.basename s = s) s @@ -29,6 +59,8 @@ module Name = struct | None -> User_error.raise ~loc [ invalid_alias s ] | Some s -> s + let encode = Dune_lang.Encoder.string + let decode = let open Dune_lang.Decoder in let* syntax = Dune_lang.Syntax.get_exn Stanza.syntax in @@ -69,28 +101,26 @@ end module T : sig type t = private { dir : Path.Build.t - ; name : string + ; name : Name.t } - val make : string -> dir:Path.Build.t -> t + val make : Name.t -> dir:Path.Build.t -> t val of_user_written_path : loc:Loc.t -> Path.t -> t end = struct type t = { dir : Path.Build.t - ; name : string + ; name : Name.t } let make name ~dir = - if String.contains name '/' then - Code_error.raise "Alias0.make: Invalid alias" - [ ("name", Dyn.Encoder.string name); ("dir", Path.Build.to_dyn dir) ]; { dir; name } let of_user_written_path ~loc path = match Path.as_in_build_dir path with | Some path -> - { dir = Path.Build.parent_exn path; name = Path.Build.basename path } + let name = Name.of_string (Path.Build.basename path) in + { dir = Path.Build.parent_exn path; name } | None -> User_error.raise ~loc [ Pp.text "Invalid alias!" @@ -102,19 +132,20 @@ end include T let compare x y = - match String.compare x.name y.name with + match Name.compare x.name y.name with | (Lt | Gt) as x -> x | Eq -> Path.Build.compare x.dir y.dir let equal x y = compare x y = Eq -let hash { dir; name } = Tuple.T2.hash Path.Build.hash String.hash (dir, name) +let hash { dir; name } = Tuple.T2.hash Path.Build.hash Name.hash (dir, name) -let pp fmt t = Path.Build.pp fmt (Path.Build.relative t.dir t.name) +let pp fmt t = + Path.Build.pp fmt (Path.Build.relative t.dir (Name.to_string t.name)) let to_dyn { dir; name } = let open Dyn in - Record [ ("dir", Path.Build.to_dyn dir); ("name", String name) ] + Record [ ("dir", Path.Build.to_dyn dir); ("name", Name.to_dyn name) ] let suffix = "-" ^ String.make 32 '0' @@ -129,9 +160,9 @@ let stamp_file_dir t = let local = Path.Build.local t.dir in Path.Build.append_local alias_dir local -let fully_qualified_name t = Path.Build.relative t.dir t.name +let fully_qualified_name t = Path.Build.relative t.dir (Name.to_string t.name) -let stamp_file t = Path.Build.relative (stamp_file_dir t) (t.name ^ suffix) +let stamp_file t = Path.Build.relative (stamp_file_dir t) ((Name.to_string t.name) ^ suffix) let find_dir_specified_on_command_line ~dir = match File_tree.find_dir dir with @@ -142,7 +173,7 @@ let find_dir_specified_on_command_line ~dir = ] | Some dir -> dir -let standard_aliases = Table.create (module String) 7 +let standard_aliases = Table.create (module Name) 7 let is_standard name = Table.mem standard_aliases name @@ -156,18 +187,18 @@ let runtest = make_standard Name.runtest let install = make_standard Name.install -let doc = make_standard "doc" +let doc = make_standard (Name.of_string "doc") -let private_doc = make_standard "doc-private" +let private_doc = make_standard (Name.of_string "doc-private") -let lint = make_standard "lint" +let lint = make_standard (Name.of_string "lint") -let all = make_standard "all" +let all = make_standard (Name.of_string "all") -let check = make_standard "check" +let check = make_standard (Name.of_string "check") -let fmt = make_standard "fmt" +let fmt = make_standard (Name.of_string "fmt") let encode { dir; name } = let open Dune_lang.Encoder in - record [ ("dir", Dpath.encode (Path.build dir)); ("name", string name) ] + record [ ("dir", Dpath.encode (Path.build dir)); ("name", Name.encode name) ] From 808f8380b503d5d7730c081557b37c09c72342c7 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Tue, 15 Oct 2019 14:46:40 +0900 Subject: [PATCH 4/5] Fix 4.07 build Signed-off-by: Rudi Grinberg --- src/dune/alias.ml | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/dune/alias.ml b/src/dune/alias.ml index f3f83217227..224bbb03028 100644 --- a/src/dune/alias.ml +++ b/src/dune/alias.ml @@ -86,8 +86,6 @@ end = struct let to_dyn = String.to_dyn - module Map = String.Map - let parse_local_path (loc, p) = match Path.Local.parent p with | Some dir -> (dir, Path.Local.basename p) From 1af72c4a5da9b33fb4f55400ef18b8f08a15ae99 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Thu, 10 Oct 2019 12:25:07 +0900 Subject: [PATCH 5/5] Add File_tree.fold_with_progress This is the only function that will report progress when scanning the directories. Signed-off-by: Rudi Grinberg --- src/dune/dune_load.ml | 2 +- src/dune/file_tree.ml | 21 ++++++++++++++------- src/dune/file_tree.mli | 4 ++++ src/dune/upgrader.ml | 5 ++--- 4 files changed, 21 insertions(+), 11 deletions(-) diff --git a/src/dune/dune_load.ml b/src/dune/dune_load.ml index 380758427a1..37bdb0cb249 100644 --- a/src/dune/dune_load.ml +++ b/src/dune/dune_load.ml @@ -206,7 +206,7 @@ let load ~ancestor_vcs () = File_tree.init Path.Source.root ~ancestor_vcs ~recognize_jbuilder_projects:false; let projects = - File_tree.Dir.fold (File_tree.root ()) + File_tree.fold_with_progress ~traverse:{ data_only = false; vendored = true; normal = true } ~init:[] ~f:(fun dir acc -> let p = File_tree.Dir.project dir in diff --git a/src/dune/file_tree.ml b/src/dune/file_tree.ml index ed9aaf897f0..4df52b863fb 100644 --- a/src/dune/file_tree.ml +++ b/src/dune/file_tree.ml @@ -252,14 +252,8 @@ let init root ~ancestor_vcs ~recognize_jbuilder_projects = let make_root { Settings.root = path; ancestor_vcs; recognize_jbuilder_projects } = let open Result.O in - let nb_path_visited = ref 0 in - Console.Status_line.set (fun () -> - Some - (Pp.verbatim (Printf.sprintf "Scanned %i directories" !nb_path_visited))); let rec walk path ~dirs_visited ~project:parent_project ~vcs ~(dir_status : Sub_dirs.Status.t) { Readdir.dirs; files } = - incr nb_path_visited; - if !nb_path_visited mod 100 = 0 then Console.Status_line.refresh (); let project = if dir_status = Data_only then parent_project @@ -364,7 +358,6 @@ let make_root ~dirs_visited:(File.Map.singleton (File.of_source_path path) path) ~dir_status:Normal ~project ~vcs:ancestor_vcs x in - Console.Status_line.set (Fn.const None); match walk with | Ok dir -> dir | Error m -> @@ -432,3 +425,17 @@ let dir_exists path = Option.is_some (find_dir path) let dir_is_vendored path = Option.map ~f:(fun dir -> Dir.vendored dir) (find_dir path) + +let fold_with_progress ~traverse ~init ~f = + let root = root () in + let nb_path_visited = ref 0 in + Console.Status_line.set (fun () -> + Some (Pp.textf "Scanned %i directories" !nb_path_visited)); + let res = + Dir.fold root ~traverse ~init ~f:(fun dir acc -> + incr nb_path_visited; + if !nb_path_visited mod 100 = 0 then Console.Status_line.refresh (); + f dir acc) + in + Console.Status_line.set (Fn.const None); + res diff --git a/src/dune/file_tree.mli b/src/dune/file_tree.mli index 00307705f01..faffca3df30 100644 --- a/src/dune/file_tree.mli +++ b/src/dune/file_tree.mli @@ -71,6 +71,10 @@ val init : val root : unit -> Dir.t +(** Traverse starting from the root and report progress in the status line *) +val fold_with_progress : + traverse:Sub_dirs.Status.Set.t -> init:'a -> f:(Dir.t -> 'a -> 'a) -> 'a + val find_dir : Path.Source.t -> Dir.t option (** [nearest_dir t fn] returns the directory with the longest path that is an diff --git a/src/dune/upgrader.ml b/src/dune/upgrader.ml index 66c1a3d6977..50163bdb1fd 100644 --- a/src/dune/upgrader.ml +++ b/src/dune/upgrader.ml @@ -382,9 +382,8 @@ let upgrade_dir todo dir = let upgrade () = Dune_project.default_dune_language_version := (1, 0); let todo = { to_rename_and_edit = []; to_add = []; to_edit = [] } in - let root = File_tree.root () in - File_tree.Dir.fold root ~traverse:Sub_dirs.Status.Set.normal_only ~init:() - ~f:(fun dir () -> upgrade_dir todo dir); + File_tree.fold_with_progress ~traverse:Sub_dirs.Status.Set.normal_only + ~init:() ~f:(fun dir () -> upgrade_dir todo dir); let log fmt = Printf.ksprintf Console.print fmt in List.iter todo.to_edit ~f:(fun (fn, s) -> log "Upgrading %s...\n" (Path.Source.to_string_maybe_quoted fn);