diff --git a/bin/alias.ml b/bin/alias.ml index 35eb505195f..c47270e8e40 100644 --- a/bin/alias.ml +++ b/bin/alias.ml @@ -56,7 +56,7 @@ let of_string (root : Workspace_root.t) ~recursive s ~contexts = [ Pp.textf "@ on the command line must be followed by a valid alias name" ] else ( let dir = Path.parent_exn path in - let name = Alias.Name.of_string (Path.basename path) in + let name = Alias.Name.of_string (Path.basename path |> Filename.to_string) in in_dir ~name ~recursive ~contexts dir) ;; diff --git a/bin/describe/aliases_targets.ml b/bin/describe/aliases_targets.ml index 36fdb4158f9..976c0f4a77e 100644 --- a/bin/describe/aliases_targets.ml +++ b/bin/describe/aliases_targets.ml @@ -29,7 +29,8 @@ let ls_term (fetch_results : Path.Build.t -> string list Action_builder.t) = if Dune_engine.Context_name.equal context - (Dune_engine.Context_name.of_string dir_context_name) + (Dune_engine.Context_name.of_string + (Filename.to_string dir_context_name)) then d else User_error.raise @@ -129,8 +130,9 @@ module Targets_cmd = struct *) Some (match kind with - | Target.File -> Path.Build.basename path - | Directory -> Path.Build.basename path ^ Filename.dir_sep)) + | Target.File -> Path.Build.basename path |> Filename.to_string + | Directory -> + (Path.Build.basename path |> Filename.to_string) ^ Filename.dir_sep)) ;; let term = ls_term fetch_results diff --git a/bin/dune_init.ml b/bin/dune_init.ml index c7f7d5d492e..797199dce72 100644 --- a/bin/dune_init.ml +++ b/bin/dune_init.ml @@ -635,7 +635,7 @@ module Component = struct in [ File.make_text ~dir:(Path.Source.parent_exn opam_file) - (Path.Source.basename opam_file) + (Path.Source.basename opam_file |> Filename.to_string) content ] | Esy -> [ File.make_text ~dir "package.json" "" ] diff --git a/bin/exec.ml b/bin/exec.ml index ee3601ad8fa..175ef20fc8f 100644 --- a/bin/exec.ml +++ b/bin/exec.ml @@ -88,7 +88,7 @@ let not_found_with_suggestions ~dir ~prog = |> List.filter ~f:(fun filename -> let ext = Filename.extension filename in Filename.Extension.Or_empty.check ext Filename.Extension.exe) - |> List.map ~f:(fun filename -> "./" ^ filename) + |> List.map ~f:(fun filename -> "./" ^ Filename.to_string filename) in User_message.did_you_mean prog ~candidates in @@ -124,6 +124,10 @@ let dir_of_context common sctx = ;; let get_path common sctx ~prog = + if + String.equal (Filename.basename prog) Filename.current_dir_name + || String.equal (Filename.basename prog) Filename.parent_dir_name + then not_found ~hints:[] ~prog; let open Memo.O in let dir = dir_of_context common sctx in match Filename.analyze_program_name prog with diff --git a/bin/install_uninstall.ml b/bin/install_uninstall.ml index cce56288d60..0851eac1f82 100644 --- a/bin/install_uninstall.ml +++ b/bin/install_uninstall.ml @@ -97,7 +97,7 @@ module Workspace = struct let name = Package.name p in let dir = Package.dir p in Ok - (Path.Source.relative + (Path.Source.relative_fname dir (Dune_rules.Install_rules.install_file ~package:name ~findlib_toolchain)) ;; @@ -134,7 +134,7 @@ module Special_file = struct match e.section with | Lib -> let dst = Install.Entry.Dst.to_string e.dst in - if dst = Dune_findlib.Findlib.Package.meta_fn + if String.equal dst (Filename.to_string Dune_findlib.Findlib.Package.meta_fn) then Some META else if dst = Dune_package.fn then Some Dune_package diff --git a/bin/ocaml/ocaml_merlin.ml b/bin/ocaml/ocaml_merlin.ml index c5e8feda75e..4d9fcf187af 100644 --- a/bin/ocaml/ocaml_merlin.ml +++ b/bin/ocaml/ocaml_merlin.ml @@ -102,13 +102,13 @@ end = struct this directory. *) let get_merlin_files_paths dir = let merlin_path = - Path.Build.relative dir Dune_rules.Merlin_ident.merlin_folder_name + Path.Build.relative_fname dir Dune_rules.Merlin_ident.merlin_folder_name in Path.build merlin_path |> Path.readdir_unsorted |> Result.value ~default:[] - |> List.sort ~compare:String.compare - |> List.map ~f:(fun f -> Path.Build.relative merlin_path f |> Path.build) + |> List.sort ~compare:Filename.compare + |> List.map ~f:(fun f -> Path.Build.relative_fname merlin_path f |> Path.build) ;; module Merlin = Dune_rules.Merlin diff --git a/bin/ocaml/top.ml b/bin/ocaml/top.ml index c000fa8fab6..4617eded98d 100644 --- a/bin/ocaml/top.ml +++ b/bin/ocaml/top.ml @@ -118,7 +118,7 @@ module Module = struct then User_error.raise [ Pp.text "file is missing an extension" ]; let open Memo.O in let module_name = - let name = Filename.remove_extension filename in + let name = Filename.remove_extension filename |> Filename.to_string in Dune_lang.Module_name.of_string_user_error (Loc.none, name) |> User_error.ok_exn in let* expander = Super_context.expander sctx ~dir in diff --git a/bin/print_rules.ml b/bin/print_rules.ml index cb9161fe96f..81c3a9fb483 100644 --- a/bin/print_rules.ml +++ b/bin/print_rules.ml @@ -207,7 +207,7 @@ let action_repr = let target_names ~root names = Filename.Set.to_list_map names ~f:(fun name -> - Path.Build.relative root name |> Path.Build.to_string) + Path.Build.relative_fname root name |> Path.Build.to_string) ;; let targets_repr = @@ -223,7 +223,7 @@ let targets_repr = let rule_context (rule : Dune_engine.Reflection.Rule.t) = match Path.Build.extract_build_context rule.targets.Targets.Validated.root with | None -> None - | Some (context, _) -> Some context + | Some (context, _) -> Some (Filename.to_string context) ;; let rule_repr = diff --git a/bin/runtest_common.ml b/bin/runtest_common.ml index c5369dc7be3..134b0b78033 100644 --- a/bin/runtest_common.ml +++ b/bin/runtest_common.ml @@ -57,7 +57,7 @@ let find_cram_test cram_tests path = - [Error `Not_a_test] if not part of any test stanza *) let classify_ml_test ~sctx ~dir ~ml_file = let open Memo.O in - let ml_file_no_ext = Filename.remove_extension ml_file in + let ml_file_no_ext = Filename.remove_extension ml_file |> Filename.to_string in match Dune_lang.Module_name.of_string_opt ml_file_no_ext with | None -> Memo.return (Error `Not_a_test) | Some module_name -> @@ -108,6 +108,7 @@ let all_tests_of_dir ~sctx parent_dir = |> Filename.Array.Set.to_list |> Memo.List.filter ~f:(fun ml_file -> classify_ml_test ~sctx ~dir:parent_dir ~ml_file >>| Result.is_ok) + >>| Filename.L.to_string and+ dir_candidates = let* parent_source_dir = Source_tree.find_dir parent_dir in match parent_source_dir with @@ -158,7 +159,7 @@ let disambiguate_test_name ~sctx path = User_error.raise [ Pp.textf "%S is used by multiple test executables and cannot be run directly." - filename + (Filename.to_string filename) ] | Error `Not_a_test -> (* Assume the user intended a directory for @runtest to be used. *) @@ -182,7 +183,9 @@ let make_request ~scontexts ~to_cwd ~test_paths = | In_source_dir dir -> (* We need to adjust the path here to make up for the current working directory. *) let dir = - Path.Source.L.relative Path.Source.root (to_cwd @ Path.Source.explode dir) + Path.Source.L.relative + Path.Source.root + (to_cwd @ (Path.Source.explode dir |> Filename.L.to_string)) in let sctx = match Context_name.Map.find scontexts Context_name.default with diff --git a/bin/subst.ml b/bin/subst.ml index 2c7edc713fc..ccab146c01e 100644 --- a/bin/subst.ml +++ b/bin/subst.ml @@ -193,7 +193,7 @@ module Dune_project = struct ; project : Dune_project.t } - let filename = Path.Source.of_string Dune_project.filename + let filename = Path.Source.of_string (Filename.to_string Dune_project.filename) let load ~dir ~files ~infer_from_opam_files = let open Memo.O in @@ -364,7 +364,7 @@ let subst vcs = |> Filename.Array.Set.fold ~init:Path.Source.Set.empty ~f:(fun fname acc -> - Path.Source.relative (Source_tree.Dir.path dir) fname + Path.Source.relative_fname (Source_tree.Dir.path dir) fname |> Path.Source.Set.add acc) |> Memo.return) in @@ -380,8 +380,7 @@ let subst vcs = (* Filter-out files form sub-directories *) List.filter_map files ~f:(fun fn -> let fn = Path.source fn in - (* CR-soon rgrinberg: this conversion to string looks wrong *) - if Path.is_root (Path.parent_exn fn) then Some (Path.to_string fn) else None) + if Path.is_root (Path.parent_exn fn) then Some (Path.basename fn) else None) |> Filename.Array.Set.of_list in Dune_project.load ~dir:Path.Source.root ~files ~infer_from_opam_files:true) diff --git a/bin/workspace_root.ml b/bin/workspace_root.ml index 1e868564861..27b846293ef 100644 --- a/bin/workspace_root.ml +++ b/bin/workspace_root.ml @@ -17,7 +17,7 @@ module Kind = struct let lowest_priority = max_int let of_dir_contents files = - if String.Set.mem files Source.Workspace.filename + if Filename.Set.mem files Source.Workspace.filename then Some Dune_workspace else if Filename.Set.mem files Dune_lang.Dune_project.filename then Some Dune_project @@ -56,7 +56,9 @@ let find from = ]; candidate | files -> - let files = String.Set.of_list (Array.to_list files) in + let files = + Array.to_list files |> List.map ~f:Filename.of_string_exn |> Filename.Set.of_list + in let candidate = let candidate_priority = match candidate with diff --git a/otherlibs/stdune/src/filename.ml b/otherlibs/stdune/src/filename.ml index 624c793efff..6b2813980cc 100644 --- a/otherlibs/stdune/src/filename.ml +++ b/otherlibs/stdune/src/filename.ml @@ -2,11 +2,39 @@ include Stdlib.Filename type t = string -let repr = Repr.string +let is_valid s = + (not (String.is_empty s)) + && (not (String.equal s current_dir_name)) + && (not (String.equal s parent_dir_name)) + && not (String.contains s '/') +;; + +let of_string s = Option.some_if (is_valid s) s + +let of_string_exn s = + match of_string s with + | Some t -> t + | None -> + Code_error.raise + "Filename.of_string_exn: invalid filename" + [ "filename", Dyn.string s ] +;; + +let to_string t = t +let append dir t = concat dir (to_string t) +let to_dyn t = Dyn.string (to_string t) +let pp t = Pp.text (to_string t) +let remove_extension t = Stdlib.Filename.remove_extension t +let repr = Repr.view Repr.string ~to_:to_string + +module L = struct + let to_string t = t +end module Extension = struct type t = string + let filename_of_string_exn = of_string_exn let corrected = ".corrected" let ml = ".ml" let mli = ".mli" @@ -29,6 +57,7 @@ module Extension = struct let cmi_dump = ".cmi.dump" let cmo_dump = ".cmo.dump" let exe = ".exe" + let expected = ".expected" let bc = ".bc" let bc_exe = ".bc.exe" let ml_gen = ".ml-gen" @@ -37,6 +66,7 @@ module Extension = struct let cms = ".cms" let cmsi = ".cmsi" let odoc = ".odoc" + let opam = ".opam" let d = ".d" let js = ".js" let h = ".h" @@ -59,6 +89,7 @@ module Extension = struct ;; let to_string t = t + let to_filename t = filename_of_string_exn t let compare = String.compare let equal = String.equal let hash = String.hash @@ -93,6 +124,12 @@ module Extension = struct let is_empty s = s = empty let is_extension s = not (is_empty s) + let drop_suffix string t = + if is_empty t + then string + else String.sub string ~pos:0 ~len:(String.length string - String.length t) + ;; + let extension = function | "" -> None | s -> Some s @@ -105,19 +142,67 @@ module Extension = struct end end +let actions_dir_basename = ".actions" +let bin_dir_basename = ".bin" +let cc_vendor = "cc_vendor" +let cinaps_corrected = ".cinaps-corrected" +let checksum = "checksum" +let coqc = "coqc" +let corrected = Extension.to_filename Extension.corrected +let dev_tool_dir_basename = ".dev-tool" +let dev_tool_locks_dir_basename = ".dev-tool-locks" +let doc_dir_basename = "_doc" +let doc_new_dir_basename = "_doc_new" +let dune = "dune" +let dune_dir_basename = ".dune" +let dune_file = "dune-file" +let dune_project = "dune-project" +let dune_workspace = "dune-workspace" +let expected = Extension.to_filename Extension.expected +let fdo_profile = ".fdo-profile" +let formatted_dir_basename = ".formatted" +let generated = ".generated" +let git_dir_basename = ".git" +let gmake = "gmake" +let hg_dir_basename = ".hg" +let jbuild = "jbuild" +let json = Extension.to_filename Extension.json +let js_dir_basename = Extension.to_filename Extension.js +let lock_dune = "lock.dune" +let linker_script = ".linker-script" +let lock_dir_basename = ".lock" +let make = "make" +let mdx_deps = ".mdx.deps" +let merlin_conf_dir_basename = ".merlin-conf" +let meta = "META" +let ocamlfind = "ocamlfind" +let opam = "opam" +let ppx_dir_basename = ".ppx" +let pkg_dir_basename = ".pkg" +let rocq = "rocq" +let run_t = "run.t" +let template = ".template" +let topmod_dir_basename = ".topmod" +let url = "url" +let utop_dir_basename = ".utop" +let findlib_conf = "findlib.conf" +let extension fn = Stdlib.Filename.extension fn |> Extension.Or_empty.of_string_exn + let split_extension fn = let ext = extension fn in - if String.is_empty ext - then fn, Extension.Or_empty.empty - else String.sub fn ~pos:0 ~len:(String.length fn - String.length ext), ext + Extension.Or_empty.drop_suffix fn ext, ext ;; let split_extension_after_dot fn = - match extension fn with + match Extension.Or_empty.to_string (extension fn) with | "" -> fn, "" | s -> String.split_n fn (String.length fn - String.length s + 1) ;; +let add_extension fn ext = fn ^ Extension.to_string ext +let set_extension fn ext = add_extension (remove_extension fn) ext +let extend fn ~suffix = fn ^ suffix + type program_name_kind = | In_path | Relative_to_current_dir @@ -133,6 +218,7 @@ let analyze_program_name fn = let compare = String.compare let equal = String.equal +let hash = String.hash let chop_extension = `Use_remove_extension module Set = String.Set @@ -143,5 +229,5 @@ module Array = Array0.Sorted.Make (struct type nonrec t = t let compare = compare - let to_dyn = Dyn.string + let to_dyn t = Dyn.string (to_string t) end) diff --git a/otherlibs/stdune/src/filename.mli b/otherlibs/stdune/src/filename.mli index 5131faad8f0..99b6ce7d763 100644 --- a/otherlibs/stdune/src/filename.mli +++ b/otherlibs/stdune/src/filename.mli @@ -1,6 +1,7 @@ -(** Represent a path component. +(** Represent a non-empty path component. - A path component is just a string without a '/' character. *) + A path component is just a non-empty string without a '/' character. It + cannot be ["."] or [".."]. *) val current_dir_name : string val parent_dir_name : string @@ -8,18 +9,31 @@ val dir_sep : string val concat : string -> string -> string val is_relative : string -> bool val check_suffix : string -> string -> bool -val remove_extension : string -> string val basename : string -> string val dirname : string -> string val get_temp_dir_name : unit -> string val quote : string -> string -(* TODO add invariants and make this abstract or private *) -type t = string +type t +val of_string : string -> t option +val of_string_exn : string -> t +val to_string : t -> string + +(** [append dir fn] is [concat dir (to_string fn)]. *) +val append : string -> t -> string + +val to_dyn : t -> Dyn.t +val pp : t -> 'a Pp.t +val remove_extension : t -> t val repr : t Repr.t +module L : sig + val to_string : t list -> string list +end + module Extension : sig + type filename := t type t val corrected : t @@ -44,6 +58,7 @@ module Extension : sig val cmi_dump : t val cmo_dump : t val exe : t + val expected : t val bc : t val bc_exe : t val ml_gen : t @@ -52,6 +67,7 @@ module Extension : sig val cms : t val cmsi : t val odoc : t + val opam : t val h : t val d : t val js : t @@ -60,6 +76,7 @@ module Extension : sig val of_string : string -> t option val of_string_exn : string -> t val to_string : t -> string + val to_filename : t -> filename val compare : t -> t -> Ordering.t val equal : t -> t -> bool val hash : t -> int @@ -78,25 +95,74 @@ module Extension : sig val to_string : t -> string val is_empty : t -> bool val is_extension : t -> bool + val drop_suffix : string -> t -> string val extension : t -> extension option val extension_exn : t -> extension end end -val extension : string -> Extension.Or_empty.t -val split_extension : t -> string * Extension.Or_empty.t -val split_extension_after_dot : t -> string * string +val extension : t -> Extension.Or_empty.t +val split_extension : t -> t * Extension.Or_empty.t +val split_extension_after_dot : t -> t * string +val add_extension : t -> Extension.t -> t +val set_extension : t -> Extension.t -> t +val extend : t -> suffix:t -> t +val actions_dir_basename : t +val bin_dir_basename : t +val cinaps_corrected : t +val cc_vendor : t +val checksum : t +val coqc : t +val corrected : t +val dev_tool_dir_basename : t +val dev_tool_locks_dir_basename : t +val doc_dir_basename : t +val doc_new_dir_basename : t +val dune : t +val dune_dir_basename : t +val dune_file : t +val dune_project : t +val dune_workspace : t +val expected : t +val fdo_profile : t +val formatted_dir_basename : t +val generated : t +val git_dir_basename : t +val gmake : t +val hg_dir_basename : t +val jbuild : t +val json : t +val js_dir_basename : t +val lock_dune : t +val linker_script : t +val lock_dir_basename : t +val make : t +val mdx_deps : t +val merlin_conf_dir_basename : t +val meta : t +val ocamlfind : t +val opam : t +val ppx_dir_basename : t +val pkg_dir_basename : t +val rocq : t +val run_t : t +val template : t +val topmod_dir_basename : t +val url : t +val utop_dir_basename : t +val findlib_conf : t type program_name_kind = | In_path | Relative_to_current_dir | Absolute -val analyze_program_name : t -> program_name_kind +val analyze_program_name : string -> program_name_kind val equal : t -> t -> bool val compare : t -> t -> Ordering.t +val hash : t -> int val chop_extension : [ `Use_remove_extension ] -module Set = String.Set -module Map = String.Map +module Map : Map.S with type key = t +module Set : Set.S with type elt = t and type 'a map = 'a Map.t module Array : Array_intf.S with type Set.elt = t diff --git a/otherlibs/stdune/src/filename_set.ml b/otherlibs/stdune/src/filename_set.ml index 84fff72f0a7..10a85836ede 100644 --- a/otherlibs/stdune/src/filename_set.ml +++ b/otherlibs/stdune/src/filename_set.ml @@ -22,5 +22,6 @@ let create ?filter ~dir filenames = ;; let to_list { dir; filenames } = - Filename.Array.Set.to_list_map filenames ~f:(Path.relative dir) + Filename.Array.Set.to_list_map filenames ~f:(fun filename -> + Path.relative_fname dir filename) ;; diff --git a/otherlibs/stdune/src/filename_set.mli b/otherlibs/stdune/src/filename_set.mli index f1462c6a1a7..c87ead4609c 100644 --- a/otherlibs/stdune/src/filename_set.mli +++ b/otherlibs/stdune/src/filename_set.mli @@ -16,5 +16,10 @@ val empty : dir:Path.t -> t val is_empty : t -> bool (* CR-soon amokhov: Decouple [create] from [filter]. *) -val create : ?filter:(basename:string -> bool) -> dir:Path.t -> Filename.Array.Set.t -> t +val create + : ?filter:(basename:Filename.t -> bool) + -> dir:Path.t + -> Filename.Array.Set.t + -> t + val to_list : t -> Path.t list diff --git a/otherlibs/stdune/src/fpath.ml b/otherlibs/stdune/src/fpath.ml index 86900506cd8..22f560da0bf 100644 --- a/otherlibs/stdune/src/fpath.ml +++ b/otherlibs/stdune/src/fpath.ml @@ -245,6 +245,7 @@ let rm_rf ?(chmod = false) fn = ;; let default ~dir:_ _ acc = acc +let filename = Filename.of_string_exn (* CR-someday rgrinberg: maybe we should make sure that we don't hit any symlink loops here? *) @@ -270,20 +271,21 @@ let traverse [ Pp.textf "unrecognized file kind %s in %S" (File_kind.to_string_hum kind) - (Filename.concat dir fname) + (Filename.append dir fname) ] in let handle_kind ~dir fname kind stack acc = + let filename = filename fname in match (kind : Unix.file_kind) with | S_DIR -> - (match enter_dir ~dir fname with + (match enter_dir ~dir filename with | false -> stack, acc | true -> - let acc = on_dir ~dir fname acc in + let acc = on_dir ~dir filename acc in let stack = Filename.concat dir fname :: stack in stack, acc) - | S_REG -> stack, on_file ~dir fname acc - | kind -> stack, on_other ~dir fname kind acc + | S_REG -> stack, on_file ~dir filename acc + | kind -> stack, on_other ~dir filename kind acc in let on_error = match on_error with @@ -328,7 +330,7 @@ let traverse stack, on_error ~dir (x, y, z) acc | stat -> handle_kind ~dir fname stat.st_kind stack acc) | `Call f -> - let acc, kind = f ~dir fname acc in + let acc, kind = f ~dir (filename fname) acc in (match kind with | None -> stack, acc | Some kind -> handle_kind ~dir fname kind stack acc)) @@ -343,7 +345,7 @@ let traverse_files ~dir ~init ~f = let skip = fun ~dir:_ _fname acc -> acc in let root = dir in let on_symlink ~dir fname acc = - let path = Filename.concat (Filename.concat root dir) fname in + let path = Filename.append (Filename.concat root dir) fname in match Unix.stat path with | { Unix.st_kind = kind; _ } -> acc, Some kind | exception Unix.Unix_error (Unix.ENOENT, _, _) -> acc, None diff --git a/otherlibs/stdune/src/path.ml b/otherlibs/stdune/src/path.ml index fc0bf432045..deadb92577d 100644 --- a/otherlibs/stdune/src/path.ml +++ b/otherlibs/stdune/src/path.ml @@ -32,6 +32,8 @@ module Local = struct [ Pp.textf "path outside the workspace: %s from %s" path (to_string t) ] ;; + let relative_fname ?error_loc t fn = relative ?error_loc t (Filename.to_string fn) + let parse_string_exn ~loc s = match parse_string_result s with | Ok t -> t @@ -90,6 +92,8 @@ module Source0 = struct [ Pp.textf "path outside the workspace: %s from %s" path (to_string t) ] ;; + let relative_fname ?error_loc t fn = relative ?error_loc t (Filename.to_string fn) + let parse_string_exn ~loc s = match parse_string_result s with | Ok t -> t @@ -168,6 +172,8 @@ module Outside_build_dir = struct | External t -> External (External.relative t s) ;; + let relative_fname t fn = relative t (Filename.to_string fn) + let extend_basename t ~suffix = match t with | In_source_dir t -> In_source_dir (Source0.extend_basename t ~suffix) @@ -243,6 +249,8 @@ module Build = struct [ Pp.textf "path outside the workspace: %s from %s" path (to_string t) ] ;; + let relative_fname ?error_loc t fn = relative ?error_loc t (Filename.to_string fn) + let parse_string_exn ~loc s = match parse_string_result s with | Ok t -> t @@ -274,16 +282,16 @@ module Build = struct let extract_build_context_dir t = Option.map (split_first_component t) ~f:(fun (before, after) -> - of_local (Local.of_string before), Source0.of_local after) + of_local (Local.of_string (Filename.to_string before)), Source0.of_local after) ;; let split_sandbox_root t_original = match split_first_component t_original with - | Some (".sandbox", t) -> + | Some (component, t) when String.equal (Filename.to_string component) ".sandbox" -> let t = of_local t in (match split_first_component t with | Some (sandbox_name, t) -> - Some (of_string (".sandbox" ^ "/" ^ sandbox_name)), of_local t + Some (of_string (".sandbox" ^ "/" ^ Filename.to_string sandbox_name)), of_local t | None -> None, t_original) | Some _ | None -> None, t_original ;; @@ -490,6 +498,8 @@ let relative ?error_loc t fn = | External s -> external_ (External.relative s fn)) ;; +let relative_fname ?error_loc t fn = relative ?error_loc t (Filename.to_string fn) + let parse_string_exn ~loc s = match s with | "" | "." -> in_source_tree Source0.root @@ -776,12 +786,26 @@ let relative_to_source_in_build_or_external ?error_loc ~dir s = let path = relative ?error_loc (in_source_tree source) s in (match path with | In_source_tree s -> - in_build_dir (Build.relative (Build.of_string bctxt) (Source0.to_string s)) + in_build_dir + (Build.relative + (Build.of_string (Filename.to_string bctxt)) + (Source0.to_string s)) | In_build_dir _ | External _ -> path) ;; -let readdir_unsorted t = Readdir.read_directory (to_string t) -let readdir_unsorted_with_kinds t = Readdir.read_directory_with_kinds (to_string t) +let readdir_unsorted t = + Result.map + (Readdir.read_directory (to_string t)) + ~f:(List.map ~f:Filename.of_string_exn) +;; + +let readdir_unsorted_with_kinds t = + Result.map + (Readdir.read_directory_with_kinds (to_string t)) + ~f:(fun entries -> + List.map entries ~f:(fun (name, kind) -> Filename.of_string_exn name, kind)) +;; + let build_dir_exists () = Fpath.is_directory (to_string build_dir) let ensure_build_dir_exists () = @@ -855,7 +879,8 @@ let set_extension t ~ext = let map_extension t ~f = let base, ext = split_extension t in - extend_basename ~suffix:(Filename.Extension.Or_empty.to_string (f ext)) base + let suffix = Filename.Extension.Or_empty.to_string (f ext) in + extend_basename ~suffix:(Filename.of_string_exn suffix) base ;; module O = Comparable.Make (T) @@ -864,7 +889,9 @@ module Map = O.Map module Set = struct include O.Set - let of_listing ~dir ~filenames = of_list_map filenames ~f:(fun f -> relative dir f) + let of_listing ~dir ~filenames = + of_list_map filenames ~f:(fun f -> relative dir (Filename.to_string f)) + ;; end let source s = in_source_tree s diff --git a/otherlibs/stdune/src/path.mli b/otherlibs/stdune/src/path.mli index 13e78877159..73d55814b46 100644 --- a/otherlibs/stdune/src/path.mli +++ b/otherlibs/stdune/src/path.mli @@ -83,6 +83,7 @@ module External : sig val cwd : unit -> t val parse_string_exn : loc:Loc0.t -> string -> t val relative : t -> string -> t + val relative_fname : t -> Filename.t -> t val of_filename_relative_to_initial_cwd : string -> t val append_local : t -> Local.t -> t @@ -125,6 +126,7 @@ module Outside_build_dir : sig val hash : t -> int val relative : t -> string -> t + val relative_fname : t -> Filename.t -> t val extend_basename : t -> suffix:Filename.t -> t val append_local : t -> Local.t -> t val equal : t -> t -> bool diff --git a/otherlibs/stdune/src/path0.ml b/otherlibs/stdune/src/path0.ml index 31c8f8e2f22..6490d64627b 100644 --- a/otherlibs/stdune/src/path0.ml +++ b/otherlibs/stdune/src/path0.ml @@ -70,13 +70,16 @@ module Local_gen = struct ;; let basename t = - if is_root t - then Code_error.raise "Path.Local.basename called on the root" [] - else ( - let len = String.length t in - match String.rindex_from t (len - 1) '/' with - | None -> t - | Some i -> String.sub t ~pos:(i + 1) ~len:(len - i - 1)) + let basename = + if is_root t + then Code_error.raise "Path.Local.basename called on the root" [] + else ( + let len = String.length t in + match String.rindex_from t (len - 1) '/' with + | None -> t + | Some i -> String.sub t ~pos:(i + 1) ~len:(len - i - 1)) + in + Filename.of_string_exn basename ;; let to_dyn t = Dyn.String t @@ -125,6 +128,8 @@ module Local_gen = struct [ "t", to_dyn t; "path", String path ] ;; + let relative_fname t fn = relative t (Filename.to_string fn) + (* Check whether a path is in canonical form: no '.' or '..' components, no repeated '/' components, no backslashes '\\' (on Windows only), and not ending in a slash '/'. *) @@ -335,9 +340,16 @@ module Local_gen = struct end let reach = Reach.reach - let extend_basename t ~suffix = t ^ suffix - let extension t = Filename.extension t - let split_extension t = Filename.split_extension t + let extend_basename t ~suffix = t ^ Filename.to_string suffix + + let extension t = + Stdlib.Filename.extension t |> Filename.Extension.Or_empty.of_string_exn + ;; + + let split_extension t = + let ext = extension t in + Filename.Extension.Or_empty.drop_suffix t ext, ext + ;; let set_extension t ~ext = let base, _ = split_extension t in @@ -376,15 +388,17 @@ module Local_gen = struct then None else ( match String.lsplit2 t ~on:'/' with - | None -> Some (t, root) - | Some (before, after) -> Some (before, after |> of_string)) + | None -> Some (Filename.of_string_exn t, root) + | Some (before, after) -> Some (Filename.of_string_exn before, after |> of_string)) ;; - let explode p = if is_root p then [] else String.split p ~on:'/' + let explode p = + if is_root p then [] else String.split p ~on:'/' |> List.map ~f:Filename.of_string_exn + ;; let of_comps = function | [] -> root - | x -> String.concat ~sep:"/" x + | x -> Filename.L.to_string x |> String.concat ~sep:"/" ;; let to_string_maybe_quoted t = String.maybe_quoted t @@ -407,7 +421,9 @@ module Local_gen = struct module Set = struct include String.Set - let of_listing ~dir ~filenames = of_list_map filenames ~f:(fun f -> relative dir f) + let of_listing ~dir ~filenames = + of_list_map filenames ~f:(fun f -> relative dir (Filename.to_string f)) + ;; end end end diff --git a/otherlibs/stdune/src/path0.mli b/otherlibs/stdune/src/path0.mli index 52d3c170529..581ba5002ef 100644 --- a/otherlibs/stdune/src/path0.mli +++ b/otherlibs/stdune/src/path0.mli @@ -31,6 +31,7 @@ module Local : sig val of_comps : Filename.t list -> t val is_root : t -> bool val relative : t -> string -> t + val relative_fname : t -> Filename.t -> t val relative_result : t -> string -> (t, [ `Outside_the_workspace ]) Result.t val parse_string_result : string -> (t, [ `Outside_the_workspace ]) Result.t val append : t -> t -> t @@ -43,8 +44,8 @@ module Local : sig val relative_result : t -> string list -> (t, [ `Outside_the_workspace ]) Result.t end - val split_first_component : t -> (string * t) option - val explode : t -> string list + val split_first_component : t -> (Filename.t * t) option + val explode : t -> Filename.t list val of_local : t -> t module Prefix : sig @@ -70,6 +71,7 @@ module Source : sig val root : t val is_root : t -> bool val relative : t -> string -> t + val relative_fname : t -> Filename.t -> t val relative_result : t -> string -> (t, [ `Outside_the_workspace ]) Result.t val parse_string_result : string -> (t, [ `Outside_the_workspace ]) Result.t val append : t -> Unspecified.w Local_gen.t -> t @@ -82,8 +84,8 @@ module Source : sig val relative_result : t -> string list -> (t, [ `Outside_the_workspace ]) Result.t end - val split_first_component : t -> (string * Unspecified.w Local_gen.t) option - val explode : t -> string list + val split_first_component : t -> (Filename.t * Unspecified.w Local_gen.t) option + val explode : t -> Filename.t list val of_local : Local.t -> t val to_local : t -> Local.t @@ -110,6 +112,7 @@ module Build : sig val root : t val is_root : t -> bool val relative : t -> string -> t + val relative_fname : t -> Filename.t -> t val relative_result : t -> string -> (t, [ `Outside_the_workspace ]) Result.t val parse_string_result : string -> (t, [ `Outside_the_workspace ]) Result.t val append : t -> Unspecified.w Local_gen.t -> t @@ -122,8 +125,8 @@ module Build : sig val relative_result : t -> string list -> (t, [ `Outside_the_workspace ]) Result.t end - val split_first_component : t -> (string * Unspecified.w Local_gen.t) option - val explode : t -> string list + val split_first_component : t -> (Filename.t * Unspecified.w Local_gen.t) option + val explode : t -> Filename.t list val of_local : Local.t -> t val local : t -> Local.t diff --git a/otherlibs/stdune/src/path_external.ml b/otherlibs/stdune/src/path_external.ml index 6c4bc744ae3..7b10480f1af 100644 --- a/otherlibs/stdune/src/path_external.ml +++ b/otherlibs/stdune/src/path_external.ml @@ -8,7 +8,7 @@ let repr = Repr.view Repr.string ~to_:to_string let equal = String.equal let hash = String.hash let compare = String.compare -let extend_basename t ~suffix = t ^ suffix +let extend_basename t ~suffix = t ^ Filename.to_string suffix let of_string t = if Filename.is_relative t @@ -47,10 +47,17 @@ let relative x y = String.concat ~sep:"/" [ x; y ]) ;; +let relative_fname t fn = relative t (Filename.to_string fn) let append_local t local = relative t (Local.to_string local) -let basename t = Filename.basename t let root = of_string "/" let is_root = equal root + +let basename t = + if is_root t + then Code_error.raise "Path.External.basename called on the root" [] + else Filename.basename t |> Filename.of_string_exn +;; + let basename_opt = basename_opt ~is_root ~basename let parent t = if is_root t then None else Some (Filename.dirname t) @@ -60,8 +67,12 @@ let parent_exn t = | Some p -> p ;; -let extension t = Filename.extension t -let split_extension t = Filename.split_extension t +let extension t = Stdlib.Filename.extension t |> Filename.Extension.Or_empty.of_string_exn + +let split_extension t = + let ext = extension t in + Filename.Extension.Or_empty.drop_suffix t ext, ext +;; let set_extension t ~ext = let base, _ = split_extension t in @@ -100,5 +111,7 @@ module Map = String.Map module Set = struct include String.Set - let of_listing ~dir ~filenames = of_list_map filenames ~f:(fun f -> relative dir f) + let of_listing ~dir ~filenames = + of_list_map filenames ~f:(fun f -> relative dir (Filename.to_string f)) + ;; end diff --git a/otherlibs/stdune/src/path_external.mli b/otherlibs/stdune/src/path_external.mli index f197d569358..9c48d99a560 100644 --- a/otherlibs/stdune/src/path_external.mli +++ b/otherlibs/stdune/src/path_external.mli @@ -7,6 +7,7 @@ val root : t include Path_intf.With_loc with type t := t val relative : t -> string -> t +val relative_fname : t -> Filename.t -> t val initial_cwd : t val cwd : unit -> t val as_local : t -> string diff --git a/otherlibs/stdune/src/path_intf.ml b/otherlibs/stdune/src/path_intf.ml index 1407d202b06..33a4dab17a5 100644 --- a/otherlibs/stdune/src/path_intf.ml +++ b/otherlibs/stdune/src/path_intf.ml @@ -34,7 +34,7 @@ module type S = sig include Set.S with type elt = t and type 'a map = 'a Map.t val to_dyn : t Dyn.builder - val of_listing : dir:elt -> filenames:string list -> t + val of_listing : dir:elt -> filenames:Filename.t list -> t end val equal : t -> t -> bool @@ -49,6 +49,7 @@ module type With_loc = sig type t val relative : ?error_loc:Loc0.t -> t -> string -> t + val relative_fname : ?error_loc:Loc0.t -> t -> Filename.t -> t val parse_string_exn : loc:Loc0.t -> string -> t end @@ -79,6 +80,7 @@ module type Local_gen = sig additionally ask for an object that fixes 'w *) val to_string : 'w t -> string val of_string : string -> 'w t + val relative_fname : 'w t -> Filename.t -> 'w t (** a directory is smaller than its descendants *) val compare : 'w t -> 'w t -> Ordering.t diff --git a/otherlibs/stdune/test/filename_tests.ml b/otherlibs/stdune/test/filename_tests.ml index 4eb82895044..21a76aa5839 100644 --- a/otherlibs/stdune/test/filename_tests.ml +++ b/otherlibs/stdune/test/filename_tests.ml @@ -4,7 +4,12 @@ open Dune_tests_common let () = init () let extension s = - let ext = Filename.extension s |> Filename.Extension.Or_empty.to_string in + let ext = + Filename.of_string s + |> Option.map ~f:Filename.extension + |> Option.value ~default:(Path.extension (Path.of_string s)) + |> Filename.Extension.Or_empty.to_string + in print (Pp.text ext) ;; @@ -97,3 +102,18 @@ let%expect_test "extension or_empty validates non-empty extensions" = "./foo" -> invalid |}] ;; + +let extension_to_filename s = + match Filename.Extension.of_string_exn s |> Filename.Extension.to_filename with + | fn -> Printf.printf "%S -> %S\n" s (Filename.to_string fn) + | exception Code_error.E _ -> Printf.printf "%S -> invalid\n" s +;; + +let%expect_test "extension to_filename validates filename invariants" = + List.iter [ "."; ".ml" ] ~f:extension_to_filename; + [%expect + {| +"." -> invalid +".ml" -> ".ml" +|}] +;; diff --git a/otherlibs/stdune/test/path_tests.ml b/otherlibs/stdune/test/path_tests.ml index c7a3a130401..524cb07f554 100644 --- a/otherlibs/stdune/test/path_tests.ml +++ b/otherlibs/stdune/test/path_tests.ml @@ -23,6 +23,12 @@ let external_append_local a b = |> print_endline ;; +let external_basename s = + match Path.External.basename (Path.External.of_string s) with + | basename -> print_endline (Filename.to_string basename) + | exception Code_error.E _ -> print_endline "invalid" +;; + let descendant p ~of_ = Dyn.option Path.to_dyn (Path.descendant p ~of_) |> print_dyn let is_descendant p ~of_ = Dyn.bool (Path.is_descendant p ~of_) |> print_dyn @@ -447,6 +453,16 @@ External "/absolute/path" |}] ;; +let%expect_test "external basename validates filename invariants" = + external_basename "/"; + external_basename "/absolute/path"; + [%expect + {| +invalid +path +|}] +;; + let%expect_test _ = Path.is_managed (e "relative/path") |> Dyn.bool |> print_dyn; [%expect @@ -597,7 +613,7 @@ let%expect_test _ = let%expect_test _ = Path.Build.extract_first_component Path.Build.root - |> Dyn.(option (pair string Local.to_dyn)) + |> Dyn.(option (pair Filename.to_dyn Local.to_dyn)) |> print_dyn; [%expect {| diff --git a/otherlibs/stdune/test/temp_tests.ml b/otherlibs/stdune/test/temp_tests.ml index 5420ec3a7fe..1d63c86e5c2 100644 --- a/otherlibs/stdune/test/temp_tests.ml +++ b/otherlibs/stdune/test/temp_tests.ml @@ -8,7 +8,7 @@ let%expect_test "Temp.clear_dir works" = let path = Temp.create Dir ~prefix:"dune" ~suffix:"unit_test" in Io.write_file (Path.relative path "foo") ""; let print () = - Path.readdir_unsorted path |> Result.to_dyn (list string) opaque |> print_dyn + Path.readdir_unsorted path |> Result.to_dyn (list Filename.to_dyn) opaque |> print_dyn in print (); Temp.clear_dir path; diff --git a/src/action_plugin/action_plugin.ml b/src/action_plugin/action_plugin.ml index 167095cf90d..4745337d22b 100644 --- a/src/action_plugin/action_plugin.ml +++ b/src/action_plugin/action_plugin.ml @@ -38,7 +38,7 @@ let exec ~(ectx : context) ~(eenv : env) prog args = ~loc:ectx.rule_loc [ Pp.text "Directory targets are not compatible with dynamic actions" ]; Filename.Set.to_list_map targets.files ~f:(fun target -> - Path.Build.relative targets.root target + Path.Build.relative_fname targets.root target |> Path.build |> Path.reach ~from:eenv.working_dir) |> String.Set.of_list diff --git a/src/dune_cache/layout.ml b/src/dune_cache/layout.ml index b67f686c445..dfa6064a098 100644 --- a/src/dune_cache/layout.ml +++ b/src/dune_cache/layout.ml @@ -13,6 +13,7 @@ let cache_path ~dir ~hex = let list_entries ~storage = let open Result.O in let entries dir = + let dir = Filename.to_string dir in match String.length dir = 2 && String.for_all ~f:Char.is_lowercase_hex dir with | false -> (* Ignore directories whose name isn't a two-character hex value. *) @@ -21,6 +22,7 @@ let list_entries ~storage = let dir = storage / dir in Path.readdir_unsorted dir >>| List.filter_map ~f:(fun entry_name -> + let entry_name = Filename.to_string entry_name in match Digest.from_hex entry_name with | None -> (* Ignore entries whose names are not hex values. *) diff --git a/src/dune_digest/digest.ml b/src/dune_digest/digest.ml index 1929fc9ec52..47f0326ab6d 100644 --- a/src/dune_digest/digest.ml +++ b/src/dune_digest/digest.ml @@ -470,6 +470,7 @@ let path_with_stats_internal | Ok listing -> (match List.rev_map listing ~f:(fun name -> + let name = Filename.to_string name in let path = Path.relative path name in let stats = match Path.lstat path with diff --git a/src/dune_engine/action_trace.ml b/src/dune_engine/action_trace.ml index b4bbce1e3e0..3ecff1377ba 100644 --- a/src/dune_engine/action_trace.ml +++ b/src/dune_engine/action_trace.ml @@ -56,7 +56,7 @@ let collect { dir; digest } = let root = dir in let root_path = Path.build root in if Fpath.exists (Path.to_string root_path) then needs_cleanup := true; - let build_path_of ~dir fname = Path.Build.relative root (Filename.concat dir fname) in + let build_path_of ~dir fname = Path.Build.relative root (Filename.append dir fname) in let build_dir_of dir = if String.equal dir "" then root else Path.Build.relative root dir in diff --git a/src/dune_engine/alias.ml b/src/dune_engine/alias.ml index 9f93554be3a..acb8164e3e5 100644 --- a/src/dune_engine/alias.ml +++ b/src/dune_engine/alias.ml @@ -26,7 +26,10 @@ end = struct match Path.as_in_build_dir path with | Some path -> let name = - Path.Build.basename path |> Name.of_string_opt_loose |> Option.value_exn + Path.Build.basename path + |> Filename.to_string + |> Name.of_string_opt_loose + |> Option.value_exn in { dir = Path.Build.parent_exn path; name } | None -> @@ -64,7 +67,7 @@ let get_ctx (path : Path.Build.t) = match Path.Build.extract_first_component path with | None -> None | Some (name, sub) -> - (match Context_name.of_string_opt name with + (match Context_name.of_string_opt (Filename.to_string name) with | None -> None | Some ctx -> Some (ctx, Path.Source.of_local sub)) ;; diff --git a/src/dune_engine/build_system.ml b/src/dune_engine/build_system.ml index d660efda6a5..586320082c0 100644 --- a/src/dune_engine/build_system.ml +++ b/src/dune_engine/build_system.ml @@ -166,7 +166,7 @@ module Internal = struct let digest_target_paths d (rule : Rule.t) = let digest_target_path name = - Path.Build.relative rule.targets.root name + Path.Build.relative_fname rule.targets.root name |> Path.Build.to_string |> Digest.Manual.string d in @@ -846,7 +846,7 @@ module Internal = struct let matching_dirs = Filename.Set.to_list_map rule.targets.dirs ~f:(fun dir -> (* CR-someday rleshchinskiy: This test can probably be simplified. *) - let dir = Path.Build.relative rule.targets.root dir in + let dir = Path.Build.relative_fname rule.targets.root dir in match Path.Build.is_descendant path ~of_:dir with | true -> [ dir ] | false -> []) diff --git a/src/dune_engine/diff_action.ml b/src/dune_engine/diff_action.ml index 2e2eb75e59a..6efaa3ceb22 100644 --- a/src/dune_engine/diff_action.ml +++ b/src/dune_engine/diff_action.ml @@ -194,7 +194,7 @@ let plan_tree_diff ({ mode; source_root; _ } as t) = |> List.fold_left ~init:(add_create_directory ~announce:false plan rel) ~f:(fun plan name -> - let rel = Path.Local.relative rel name in + let rel = Path.Local.relative_fname rel name in collect_target_only rel (kind_of_target rel) plan) and loop rel source_kind target_kind plan = match source_kind, target_kind with @@ -218,7 +218,7 @@ let plan_tree_diff ({ mode; source_root; _ } as t) = then plan else List.fold_left entries ~init:plan ~f:(fun plan name -> - let rel = Path.Local.relative rel name in + let rel = Path.Local.relative_fname rel name in loop rel Missing (kind_of_target rel) plan) | File, Directory -> list_target_directory rel @@ -229,32 +229,32 @@ let plan_tree_diff ({ mode; source_root; _ } as t) = plan (Pp.textf "File %s should be replaced with a directory" (path_name rel))) ~f:(fun plan name -> - let rel = Path.Local.relative rel name in + let rel = Path.Local.relative_fname rel name in collect_target_only rel (kind_of_target rel) plan) | Directory, Directory -> let rec merge source_entries target_entries plan = match source_entries, target_entries with | [], [] -> plan | name :: source_entries, [] -> - let rel = Path.Local.relative rel name in + let rel = Path.Local.relative_fname rel name in let plan = loop rel (kind_of_source rel) Missing plan in merge source_entries [] plan | [], name :: target_entries -> - let rel = Path.Local.relative rel name in + let rel = Path.Local.relative_fname rel name in let plan = loop rel Missing (kind_of_target rel) plan in merge [] target_entries plan | source_name :: source_entries, target_name :: target_entries -> (match Filename.compare source_name target_name with | Lt -> - let rel = Path.Local.relative rel source_name in + let rel = Path.Local.relative_fname rel source_name in let plan = loop rel (kind_of_source rel) Missing plan in merge source_entries (target_name :: target_entries) plan | Eq -> - let rel = Path.Local.relative rel source_name in + let rel = Path.Local.relative_fname rel source_name in let plan = loop rel (kind_of_source rel) (kind_of_target rel) plan in merge source_entries target_entries plan | Gt -> - let rel = Path.Local.relative rel target_name in + let rel = Path.Local.relative_fname rel target_name in let plan = loop rel Missing (kind_of_target rel) plan in merge (source_name :: source_entries) target_entries plan) in diff --git a/src/dune_engine/dir_set.ml b/src/dune_engine/dir_set.ml index 396864b2c78..509bdb244ee 100644 --- a/src/dune_engine/dir_set.ml +++ b/src/dune_engine/dir_set.ml @@ -55,7 +55,7 @@ let is_universal = function ;; let merge_exceptions a b ~default ~f = - String.Map.merge a.exceptions b.exceptions ~f:(fun _ x y -> + Filename.Map.merge a.exceptions b.exceptions ~f:(fun _ x y -> let x = Option.value x ~default:(trivial a.default) in let y = Option.value y ~default:(trivial b.default) in match default, f x y with @@ -179,7 +179,8 @@ let rec to_dyn = (((match here with | true -> [ ".", String "true" ] | false -> []) - @ Filename.Map.to_list_map exceptions ~f:(fun s t -> s, to_dyn t) + @ Filename.Map.to_list_map exceptions ~f:(fun s t -> + Filename.to_string s, to_dyn t) @ match default with | false -> [] diff --git a/src/dune_engine/dpath.ml b/src/dune_engine/dpath.ml index 9da183f561a..e7e0893e5a7 100644 --- a/src/dune_engine/dpath.ml +++ b/src/dune_engine/dpath.ml @@ -3,8 +3,11 @@ open Import module Build = struct type t = Path.Build.t - let anonymous_actions_dir_basename = ".actions" - let anonymous_actions_dir = Path.Build.(relative root) anonymous_actions_dir_basename + let anonymous_actions_dir_basename = Filename.actions_dir_basename + + let anonymous_actions_dir = + Path.Build.(relative root) (Filename.to_string anonymous_actions_dir_basename) + ;; end type target_kind = @@ -34,15 +37,15 @@ module Target_dir = struct match Path.Build.extract_first_component fn with | None -> Regular Root | Some (name, sub) -> - if name = Build.anonymous_actions_dir_basename + if Filename.equal name Build.anonymous_actions_dir_basename then ( match Path.Local.split_first_component sub with | None -> Anonymous_action Root | Some (ctx, fn) -> - let ctx = Context_name.of_string ctx in + let ctx = Context_name.of_string (Filename.to_string ctx) in Anonymous_action (With_context (ctx, Path.Source.of_local fn))) else ( - match Context_name.of_string_opt name with + match Context_name.of_string_opt (Filename.to_string name) with | None -> Invalid fn | Some ctx -> Regular (With_context (ctx, Path.Source.of_local sub))) ;; @@ -63,7 +66,7 @@ let analyse_target (fn as original_fn) : target_kind = if Path.Source.is_root fn then Other original_fn else ( - let basename = Path.Source.basename fn in + let basename = Path.Source.basename fn |> Filename.to_string in match String.rsplit2 basename ~on:'-' with | None -> if is_digest basename then Anonymous_action ctx else Other original_fn | Some (basename, suffix) -> diff --git a/src/dune_engine/file_selector.ml b/src/dune_engine/file_selector.ml index a2f9658a759..5dd30ac1df7 100644 --- a/src/dune_engine/file_selector.ml +++ b/src/dune_engine/file_selector.ml @@ -51,9 +51,12 @@ let test t path = Predicate_lang.Glob.test t.predicate ~standard:Predicate_lang.false_ - (Path.basename path) + (Path.basename path |> Filename.to_string) ;; let test_basename t ~basename = - Predicate_lang.Glob.test t.predicate ~standard:Predicate_lang.false_ basename + Predicate_lang.Glob.test + t.predicate + ~standard:Predicate_lang.false_ + (Filename.to_string basename) ;; diff --git a/src/dune_engine/file_selector.mli b/src/dune_engine/file_selector.mli index ac2d324fbca..1d5862198a6 100644 --- a/src/dune_engine/file_selector.mli +++ b/src/dune_engine/file_selector.mli @@ -26,5 +26,5 @@ val repr : t Repr.t val to_dyn : t -> Dyn.t val test : t -> Path.t -> bool -val test_basename : t -> basename:string -> bool +val test_basename : t -> basename:Filename.t -> bool val digest : t -> Digest.t diff --git a/src/dune_engine/load_rules.ml b/src/dune_engine/load_rules.ml index d9400e79d0d..1626c04bc10 100644 --- a/src/dune_engine/load_rules.ml +++ b/src/dune_engine/load_rules.ml @@ -108,7 +108,9 @@ let get_dir_triage ~dir = let+ contexts = Memo.Lazy.force (Build_config.get ()).contexts in let allowed_subdirs = [ Path.Build.basename Dpath.Build.anonymous_actions_dir ] - @ (Context_name.Map.keys contexts |> List.map ~f:Context_name.to_string) + @ (Context_name.Map.keys contexts + |> List.map ~f:(fun name -> Filename.of_string_exn (Context_name.to_string name)) + ) |> Subdir_set.of_list |> Subdir_set.to_dir_set in @@ -195,7 +197,7 @@ let remove_old_artifacts | Error _ -> () | Ok files -> List.iter files ~f:(fun (fn, kind) -> - let path = Path.Build.relative dir fn in + let path = Path.Build.relative_fname dir fn in let path_is_a_target = Path.Build.Map.mem rules_here.by_file_targets path || Path.Build.Map.mem rules_here.by_directory_targets path @@ -220,7 +222,7 @@ let remove_old_sub_dirs_in_anonymous_actions_dir ~dir ~(subdirs_to_keep : Subdir | Error _ -> () | Ok files -> List.iter files ~f:(fun (fn, kind) -> - let path = Path.Build.relative dir fn in + let path = Path.Build.relative_fname dir fn in match kind with | Unix.S_DIR -> if not (Subdir_set.mem subdirs_to_keep fn) @@ -301,7 +303,7 @@ end = struct let create_copy_rules ~dir ~ctx_dir ~non_target_source_filenames = Filename.Array.Set.to_list_map non_target_source_filenames ~f:(fun filename -> - let src_path = Path.Source.relative dir filename in + let src_path = Path.Source.relative_fname dir filename in let build_path = Path.Build.append_source ctx_dir src_path in Rule.make ~info:(Source_file_copy src_path) @@ -313,16 +315,16 @@ end = struct let file_targets, directory_targets = let check_for_source_dir_conflict rule target = if Filename.Array.Set.mem source_dirs target - then report_rule_src_dir_conflict dir target rule + then report_rule_src_dir_conflict dir (Filename.to_string target) rule in List.map rules ~f:(fun rule -> assert (Path.Build.( = ) dir rule.Rule.targets.root); ( Filename.Set.to_list_map rule.targets.files ~f:(fun target -> check_for_source_dir_conflict rule target; - Path.Build.relative rule.targets.root target, rule) + Path.Build.relative_fname rule.targets.root target, rule) , Filename.Set.to_list_map rule.targets.dirs ~f:(fun target -> check_for_source_dir_conflict rule target; - Path.Build.relative rule.targets.root target, rule) )) + Path.Build.relative_fname rule.targets.root target, rule) )) |> List.unzip in let by_file_targets = @@ -419,12 +421,16 @@ end = struct ; Pp.text "The following targets are present:" ; Pp.enumerate ~f:Path.pp - (Filename.Array.Set.to_list_map present_targets ~f:(Path.relative dir)) + (Filename.Array.Set.to_list_map + present_targets + ~f:(Path.relative_fname dir)) ; Pp.nop ; Pp.text "The following targets are not:" ; Pp.enumerate ~f:Path.pp - (Filename.Array.Set.to_list_map absent_targets ~f:(Path.relative dir)) + (Filename.Array.Set.to_list_map + absent_targets + ~f:(Path.relative_fname dir)) ])) ;; @@ -586,7 +592,7 @@ end = struct d) = let (module RG : Rule_generator) = (Build_config.get ()).rule_generator in - let sub_dir_components = Path.Source.explode sub_dir in + let sub_dir_components = Path.Source.explode sub_dir |> Filename.L.to_string in RG.gen_rules context_name ~dir sub_dir_components >>= function | Rules rules -> Memo.return @@ Normal (Normal.make_rules_gen_result ~of_:dir rules) @@ -633,7 +639,7 @@ end = struct [ Pp.textf "This rule defines a target %S whose name conflicts with an internal directory \ used by Dune. Please use a different name." - target_name + (Filename.to_string target_name) ] ;; @@ -676,10 +682,7 @@ end = struct match only with | None -> target_filenames | Some pred -> - let is_promoted filename = - let file = Path.Build.relative dir filename in - Predicate.test pred (Path.reach (Path.build file) ~from:(Path.build dir)) - in + let is_promoted filename = Predicate.test pred filename in Filename.Set.filter target_filenames ~f:is_promoted in iter @@ -762,7 +765,7 @@ end = struct in let source_dirs_to_keep = Filename.Array.Set.fold source_dirs ~init:Dir_set.empty ~f:(fun path acc -> - let path = Path.Local.of_string path in + let path = Path.Local.relative_fname Path.Local.root path in Dir_set.union acc (Dir_set.singleton path)) in let subdirs_to_keep = diff --git a/src/dune_engine/process.ml b/src/dune_engine/process.ml index fbb121591af..41e2c90ba29 100644 --- a/src/dune_engine/process.ml +++ b/src/dune_engine/process.ml @@ -435,7 +435,10 @@ module Short_display = struct split_paths [] Context_name.Set.empty targets in let targets = - List.map target_names ~f:Filename.split_extension_after_dot + List.map target_names ~f:(fun fn -> + match Stdlib.Filename.extension fn with + | "" -> fn, "" + | s -> String.split_n fn (String.length fn - String.length s + 1)) |> String.Map.of_list_multi |> String.Map.to_list_map ~f:(fun prefix suffixes -> match suffixes with diff --git a/src/dune_engine/rules.ml b/src/dune_engine/rules.ml index 783bc266075..0df70b45ed8 100644 --- a/src/dune_engine/rules.ml +++ b/src/dune_engine/rules.ml @@ -192,7 +192,7 @@ let directory_targets (rules : t) = | Alias _ -> acc | Rule rule -> Filename.Set.fold ~init:acc rule.targets.dirs ~f:(fun target acc -> - let target = Path.Build.relative rule.targets.root target in + let target = Path.Build.relative_fname rule.targets.root target in Path.Build.Map.add_exn acc target rule.loc))) ;; diff --git a/src/dune_engine/sandbox.ml b/src/dune_engine/sandbox.ml index 6f5031aac94..e60730e87fa 100644 --- a/src/dune_engine/sandbox.ml +++ b/src/dune_engine/sandbox.ml @@ -196,10 +196,10 @@ let snapshot t = ~dir:(Path.to_string root) ~init:Path.Map.empty ~on_dir:(fun ~dir fname acc -> - let path = Path.relative root (Filename.concat dir fname) in + let path = Path.relative root (Filename.append dir fname) in Path.Map.add_exn acc path `Dir) ~on_file:(fun ~dir fname acc -> - let p = Path.relative root (Filename.concat dir fname) in + let p = Path.relative root (Filename.append dir fname) in let stats = Stat.stat (Path.to_string p) in Path.Map.add_exn acc p (`File stats)) ~on_other:`Ignore @@ -221,11 +221,12 @@ let find_corrected_files (t : real) ~deps = ~init:[] ~on_dir:(fun ~dir:_ _ acc -> acc) ~enter_dir:(fun ~dir:_ fname -> + let fname = Filename.to_string fname in (* We don't want to traverse the corrections produced by a nested dune *) not (String.equal fname ".sandbox" || String.equal fname "_build")) ~on_file:(fun ~dir fname acc -> match - let path = Path.Build.relative t.dir (Filename.concat dir fname) in + let path = Path.Build.relative t.dir (Filename.append dir fname) in if let extension = Filename.extension fname in Filename.Extension.Or_empty.check extension Filename.Extension.corrected @@ -258,7 +259,7 @@ let build_path_without_corrected_suffix path = assert (Filename.Extension.Or_empty.check extension Filename.Extension.corrected); let basename = Filename.remove_extension basename in let parent = Path.Build.parent_exn path in - Path.Build.relative parent basename + Path.Build.relative_fname parent basename ;; let register_corrected_file_promotions t ~deps = diff --git a/src/dune_engine/subdir_set.ml b/src/dune_engine/subdir_set.ml index 4a77d218171..c98f8276ea3 100644 --- a/src/dune_engine/subdir_set.ml +++ b/src/dune_engine/subdir_set.ml @@ -11,7 +11,7 @@ let to_dir_set = function | All -> Dir_set.universal | These s -> Filename.Set.fold s ~init:Dir_set.empty ~f:(fun path acc -> - let path = Path.Local.of_string path in + let path = Path.Local.relative_fname Path.Local.root path in Dir_set.union acc (Dir_set.singleton path)) ;; diff --git a/src/dune_engine/target_promotion.ml b/src/dune_engine/target_promotion.ml index 9b72112511c..3901ad19e2c 100644 --- a/src/dune_engine/target_promotion.ml +++ b/src/dune_engine/target_promotion.ml @@ -108,7 +108,7 @@ let promote ~(targets : _ Targets.Produced.t) ~(promote : Rule.Promote.t) ~promo let selected_for_promotion : Path.Local.t -> bool = match promote.only with | None -> fun (_ : Path.Local.t) -> true - | Some pred -> fun target -> Predicate.test pred (Path.Local.to_string target) + | Some pred -> fun target -> Predicate.test pred (Path.Local.basename target) in let open Fiber.O in (* Map target paths taking into account the (promote (into )) field. *) @@ -136,7 +136,7 @@ let promote ~(targets : _ Targets.Produced.t) ~(promote : Rule.Promote.t) ~promo Memo.run (Fs_memo.path_kind (In_source_dir into_dir)) >>| (function | Ok S_DIR | Error (ENOENT, _, _) -> - fun src -> Path.Source.relative into_dir (Path.Build.basename src) + fun src -> Path.Source.relative_fname into_dir (Path.Build.basename src) | Ok _other_kind -> promote_into_error (Pp.textf "%S is not a directory.") | Error unix_error -> promote_into_error ~unix_error (Pp.textf "Cannot promote to directory %S.")) @@ -218,13 +218,16 @@ let promote ~(targets : _ Targets.Produced.t) ~(promote : Rule.Promote.t) ~promo Fs_memo.Dir_contents.iter dir_contents ~f:(fun file_name kind -> match kind with | S_REG -> - if not (Targets.Produced.mem targets (Path.Build.relative build_dir file_name)) - then Fpath.unlink_no_err (Path.to_string (Path.relative dst_dir file_name)) + let file_name_s = Filename.to_string file_name in + if + not (Targets.Produced.mem targets (Path.Build.relative build_dir file_name_s)) + then Fpath.unlink_no_err (Path.to_string (Path.relative dst_dir file_name_s)) | S_DIR -> - let src_dir = Path.Build.relative build_dir file_name in + let src_dir = Path.Build.relative_fname build_dir file_name in if not (Targets.Produced.mem_dir targets src_dir) - then Path.rm_rf (Path.relative dst_dir file_name) - | _kind -> Fpath.unlink_no_err (Path.to_string (Path.relative dst_dir file_name))) + then Path.rm_rf (Path.relative_fname dst_dir file_name) + | _kind -> + Fpath.unlink_no_err (Path.to_string (Path.relative_fname dst_dir file_name))) in Fiber.sequential_iter_seq (Targets.Produced.all_dirs_seq targets) ~f:(fun dir -> remove_stale_files_and_subdirectories ~dir) diff --git a/src/dune_engine/tree_copy.ml b/src/dune_engine/tree_copy.ml index 086837e008e..03d0fe7dd4e 100644 --- a/src/dune_engine/tree_copy.ml +++ b/src/dune_engine/tree_copy.ml @@ -10,19 +10,19 @@ let copy ~src ~dst ~copy_file ~mkdir ~on_unsupported ?(on_symlink = `Raise) () = ~dir:(Path.to_string src) ~init:() ~on_file:(fun ~dir fname () -> - let rel = Filename.concat dir fname in + let rel = Filename.append dir fname in let src = Path.relative src rel in let dst = Path.relative dst rel in copy_file ~src ~dst) ~on_dir:(fun ~dir fname () -> - let rel = Filename.concat dir fname in + let rel = Filename.append dir fname in let src = Path.relative src rel in let dst = Path.relative dst rel in mkdir ~src ~dst) ~on_other: (`Call (fun ~dir fname kind () -> - let src = Path.relative src (Filename.concat dir fname) in + let src = Path.relative src (Filename.append dir fname) in on_unsupported ~src kind)) ~on_symlink: (match on_symlink with @@ -31,7 +31,7 @@ let copy ~src ~dst ~copy_file ~mkdir ~on_unsupported ?(on_symlink = `Raise) () = | `Call f -> `Call (fun ~dir fname () -> - let src = Path.relative src (Filename.concat dir fname) in + let src = Path.relative src (Filename.append dir fname) in (), f ~src)) () | kind -> on_unsupported ~src kind diff --git a/src/dune_findlib/config.ml b/src/dune_findlib/config.ml index d85305c30b3..6e000ca06a3 100644 --- a/src/dune_findlib/config.ml +++ b/src/dune_findlib/config.ml @@ -26,7 +26,11 @@ module File = struct | true -> load config_file | false -> Memo.return Vars.empty in - let config_dir = Path.Outside_build_dir.extend_basename config_file ~suffix:".d" in + let config_dir = + Path.Outside_build_dir.extend_basename + config_file + ~suffix:(Filename.Extension.to_filename Filename.Extension.d) + in Fs_memo.is_directory config_dir >>= function | Ok false | Error (_ : Unix.error * _ * _) -> Memo.return vars @@ -38,7 +42,9 @@ module File = struct Memo.parallel_map (Fs_memo.Dir_contents.to_list dir_contents) ~f:(fun (p, _kind) -> - let p = Path.Outside_build_dir.relative config_dir p in + let p = + Path.Outside_build_dir.relative config_dir (Filename.to_string p) + in load p) in List.fold_left all_vars ~init:vars ~f:(fun acc vars -> @@ -55,7 +61,7 @@ end type t = { config : File.t ; ocamlpath : Path.t list Memo.t - ; which : string -> Path.t option Memo.t + ; which : Filename.t -> Path.t option Memo.t ; toolchain : string option } @@ -98,7 +104,7 @@ let tool t ~prog = | None -> Memo.return None | Some s -> (match Filename.analyze_program_name s with - | In_path -> t.which s + | In_path -> t.which (Filename.of_string_exn s) | Relative_to_current_dir -> User_error.raise [ Pp.textf @@ -132,7 +138,7 @@ let ocamlfind_config_path ~env ~which ~findlib_toolchain = compilation *) Memo.return None | Some _ -> - which "ocamlfind" + which Filename.ocamlfind >>= (function | None -> Memo.return None | Some fn -> diff --git a/src/dune_findlib/package0.ml b/src/dune_findlib/package0.ml index 930e7d9d41b..4da4f1ce7be 100644 --- a/src/dune_findlib/package0.ml +++ b/src/dune_findlib/package0.ml @@ -2,7 +2,7 @@ open Import module P = Ocaml.Variant module Ps = Ocaml.Variant.Set -let meta_fn = "META" +let meta_fn = Filename.meta let findlib_predicates_set_by_dune = Ps.of_list [ P.ppx_driver; P.mt; P.mt_posix ] type t = @@ -81,6 +81,8 @@ let exists t ~is_builtin = ;; let candidates ~dir name = - [ meta_fn ^ "." ^ Package.Name.to_string name; meta_fn ] + [ Filename.to_string meta_fn ^ "." ^ Package.Name.to_string name + ; Filename.to_string meta_fn + ] |> List.map ~f:(Path.Outside_build_dir.relative dir) ;; diff --git a/src/dune_lang/dune_project.ml b/src/dune_lang/dune_project.ml index a80a6453ff0..61487341295 100644 --- a/src/dune_lang/dune_project.ml +++ b/src/dune_lang/dune_project.ml @@ -481,7 +481,7 @@ let interpret_lang_and_extensions ~(lang : Lang.Instance.t) ~explicit_extensions parsing_context, stanza_parser, extension_args ;; -let filename = "dune-project" +let filename = Filename.dune_project let opam_file_location_default ~lang:_ = `Relative_to_project let wrapped_executables_default ~(lang : Lang.Instance.t) = lang.version >= (2, 0) let map_workspace_root_default ~(lang : Lang.Instance.t) = lang.version >= (3, 0) @@ -1114,7 +1114,7 @@ let parse ~dir ~(lang : Lang.Instance.t) ~file = ;; let load_dune_project ~read ~dir opam_packages : t Memo.t = - let file = Path.Source.relative dir filename in + let file = Path.Source.relative_fname dir filename in let open Memo.O in let* lexbuf = let+ contents = read file in @@ -1132,7 +1132,7 @@ let gen_load ~read ~dir ~files ~infer_from_opam_files ~load_opam_file_with_conte match Package.Name.of_opam_file_basename fn with | None -> acc | Some name -> - let opam_file = Path.Source.relative dir fn in + let opam_file = Path.Source.relative_fname dir fn in let loc = Loc.in_file (Path.source opam_file) in let pkg = let+ contents = read opam_file in diff --git a/src/dune_lang/file_binding.ml b/src/dune_lang/file_binding.ml index 73c8408b3b2..50030f56139 100644 --- a/src/dune_lang/file_binding.ml +++ b/src/dune_lang/file_binding.ml @@ -44,7 +44,7 @@ module Expanded = struct match dst with | Some (_, dst) -> dst | None -> - let basename = Path.Build.basename src in + let basename = Path.Build.basename src |> Filename.to_string in String.drop_suffix basename ~suffix:".exe" |> Option.value ~default:basename ;; diff --git a/src/dune_lang/foreign_language.ml b/src/dune_lang/foreign_language.ml index 504f648a43f..aa5a85a9bf4 100644 --- a/src/dune_lang/foreign_language.ml +++ b/src/dune_lang/foreign_language.ml @@ -71,7 +71,7 @@ let source_extensions = ;; let has_foreign_extension ~fn = - let ext = Filename.extension fn in + let ext = Stdlib.Filename.extension fn |> Filename.Extension.Or_empty.of_string_exn in if Filename.Extension.Or_empty.is_empty ext then false else ( diff --git a/src/dune_lang/glob.ml b/src/dune_lang/glob.ml index 4a0e6065b09..0a4227e60e2 100644 --- a/src/dune_lang/glob.ml +++ b/src/dune_lang/glob.ml @@ -17,4 +17,4 @@ let decode = ;; let filter t = List.filter ~f:(test t) -let to_predicate t = Predicate.create (test t) +let to_predicate t = Predicate.create (fun fn -> test t (Filename.to_string fn)) diff --git a/src/dune_lang/module_name.ml b/src/dune_lang/module_name.ml index 42fb5eb44a6..452fee73334 100644 --- a/src/dune_lang/module_name.ml +++ b/src/dune_lang/module_name.ml @@ -157,7 +157,7 @@ module Unique = struct ;; let of_path_assuming_needs_no_mangling_allow_invalid path = - let fn = Path.basename path in + let fn = Path.basename path |> Filename.to_string in let loc = Loc.in_file path in let name = match String.index fn '.' with diff --git a/src/dune_lang/package.ml b/src/dune_lang/package.ml index eeaad0adb04..257feb3882c 100644 --- a/src/dune_lang/package.ml +++ b/src/dune_lang/package.ml @@ -113,7 +113,10 @@ let encode ; field_b "allow_empty" allow_empty ; field_o "dir" - (fun (_, dir) -> Path.Source.basename dir |> Dune_sexp.atom_or_quoted_string) + (fun (_, dir) -> + Path.Source.basename dir + |> Filename.to_string + |> Dune_sexp.atom_or_quoted_string) exclusive_dir ] in @@ -332,7 +335,8 @@ let create ; opam_file = Name.file name ~dir ; original_opam_file ; exclusive_dir = - Option.map contents_basename ~f:(fun (loc, s) -> loc, Path.Source.relative dir s) + Option.map contents_basename ~f:(fun (loc, s) -> + loc, Path.Source.relative_fname dir s) ; duplicate_dep_warnings = [] ; enabled_if } diff --git a/src/dune_lang/package_name.ml b/src/dune_lang/package_name.ml index a4ffd0c3a5f..098fce3b0ac 100644 --- a/src/dune_lang/package_name.ml +++ b/src/dune_lang/package_name.ml @@ -65,10 +65,14 @@ module Opam_compatible = struct let to_package_name s = s end -let opam_ext = ".opam" -let opam_fn (t : t) = to_string t ^ opam_ext +let opam_ext = Filename.Extension.to_string Filename.Extension.opam + +let opam_fn (t : t) = + Filename.add_extension (Filename.of_string_exn (to_string t)) Filename.Extension.opam +;; + let is_opam_compatible s = Option.is_some (Opam_compatible.of_string_opt (to_string s)) -let file t ~dir = Path.Source.relative dir (to_string t ^ opam_ext) +let file t ~dir = Path.Source.relative_fname dir (opam_fn t) let decode_opam_compatible = Decoder.map ~f:Opam_compatible.to_package_name Opam_compatible.decode @@ -76,7 +80,7 @@ let decode_opam_compatible = let of_opam_file_basename basename = let open Option.O in - let* name = String.drop_suffix basename ~suffix:opam_ext in + let* name = String.drop_suffix (Filename.to_string basename) ~suffix:opam_ext in of_string_opt name ;; diff --git a/src/dune_lang/rule_mode_decoder.ml b/src/dune_lang/rule_mode_decoder.ml index 2e70885f789..c66c4431b9b 100644 --- a/src/dune_lang/rule_mode_decoder.ml +++ b/src/dune_lang/rule_mode_decoder.ml @@ -18,7 +18,11 @@ module Promote = struct in let only = Option.map only ~f:(fun only -> - Predicate.create (Predicate_lang.Glob.test only ~standard:Predicate_lang.true_)) + Predicate.create (fun fn -> + Predicate_lang.Glob.test + only + ~standard:Predicate_lang.true_ + (Filename.to_string fn))) in { Rule_mode.Promote.lifetime = (if until_clean then Until_clean else Unlimited) ; into diff --git a/src/dune_lang/stanza_pkg.ml b/src/dune_lang/stanza_pkg.ml index 167fc53d7b1..f46b4169cf7 100644 --- a/src/dune_lang/stanza_pkg.ml +++ b/src/dune_lang/stanza_pkg.ml @@ -67,7 +67,7 @@ let resolve (project : Dune_project.t) mask (loc, name) = "To declare elements to be installed as part of package %S, add a %S file \ at the root of your project." name_s - (Package.Name.opam_fn name) + (Package.Name.opam_fn name |> Filename.to_string) ; Pp.textf "Root of the project as discovered by dune: %s" (Path.Source.to_string_maybe_quoted (Dune_project.root project)) diff --git a/src/dune_pkg/archive_driver.ml b/src/dune_pkg/archive_driver.ml index 3c1b80ac1d4..890b2fe8b28 100644 --- a/src/dune_pkg/archive_driver.ml +++ b/src/dune_pkg/archive_driver.ml @@ -55,7 +55,7 @@ let make_tar_args ~tar_impl ~archive ~target_in_temp = then User_error.raise ~hints:[ Pp.text "Install GNU tar or bsdtar (libarchive) for XZ support." ] - [ Pp.textf "Cannot extract '%s'" (Path.basename archive) + [ Pp.textf "Cannot extract '%s'" (Path.basename archive |> Filename.to_string) ; Pp.text "The detected tar does not support XZ decompression. XZ archives require \ GNU tar or libarchive." @@ -64,7 +64,7 @@ let make_tar_args ~tar_impl ~archive ~target_in_temp = then User_error.raise ~hints:[ Pp.text "Install GNU tar or bsdtar (libarchive) for LZMA support." ] - [ Pp.textf "Cannot extract '%s'" (Path.basename archive) + [ Pp.textf "Cannot extract '%s'" (Path.basename archive |> Filename.to_string) ; Pp.text "The detected tar does not support LZMA decompression. LZMA archives \ require GNU tar or libarchive." @@ -158,9 +158,9 @@ let choose_for_filename_default_to_tar filename = let extract t ~archive ~target = let* () = Fiber.return () in let* command = Fiber.Lazy.force t.command in - let prefix = Path.basename target in + let prefix = Path.basename target |> Filename.to_string in let target_in_temp = - let suffix = Path.basename archive in + let suffix = Path.basename archive |> Filename.to_string in Temp_dir.dir_for_target ~target ~prefix ~suffix in let temp_stderr_path = Temp.create File ~prefix ~suffix:"stderr" in @@ -187,7 +187,7 @@ let extract t ~archive ~target = ; Pp.text "reason:" ; Pp.text (Unix_error.Detailed.to_string_hum e) ] - | Ok [ (fname, S_DIR) ] -> Path.relative target_in_temp fname + | Ok [ (fname, S_DIR) ] -> Path.relative_fname target_in_temp fname | Ok _ -> target_in_temp in Path.mkdir_p (Path.parent_exn target); @@ -197,11 +197,11 @@ let extract t ~archive ~target = Io.with_file_in temp_stderr_path ~f:(fun err_channel -> let stderr_lines = Io.input_lines err_channel in User_error.raise - [ Pp.textf "failed to extract '%s'" (Path.basename archive) + [ Pp.textf "failed to extract '%s'" (Path.basename archive |> Filename.to_string) ; Pp.concat ~sep:Pp.space [ Pp.text "Reason:" - ; User_message.command @@ Path.basename command.bin + ; User_message.command (Path.basename command.bin |> Filename.to_string) ; Pp.textf "failed with non-zero exit code '%d' and output:" exit_code ] ; Pp.enumerate stderr_lines ~f:Pp.text diff --git a/src/dune_pkg/archive_driver.mli b/src/dune_pkg/archive_driver.mli index 47e9ce0a103..77be1161977 100644 --- a/src/dune_pkg/archive_driver.mli +++ b/src/dune_pkg/archive_driver.mli @@ -8,14 +8,14 @@ val tar : t (** Returns the driver that can extract a file of a given name. The decision is made based on the file's suffix. *) -val choose_for_filename : Filename.t -> t option +val choose_for_filename : string -> t option (** Returns the driver that can extract a file of a given name. The decision is made based on the file's suffix. If the archive format isn't clear from the filename then this function will default to using tar as tar archives (possibly compressed) are by far the most common archive format used by opam packages. *) -val choose_for_filename_default_to_tar : Filename.t -> t +val choose_for_filename_default_to_tar : string -> t (** [extract t ~archive ~target] uses the archive driver [t] to extract the archive at [archive] into the directory at [target], creating the directory diff --git a/src/dune_pkg/fetch.ml b/src/dune_pkg/fetch.ml index 8e073665ef5..2ab27af4e3c 100644 --- a/src/dune_pkg/fetch.ml +++ b/src/dune_pkg/fetch.ml @@ -263,6 +263,7 @@ let is_descendant t ~of_ = with regular directories containing the same contents. *) let resolve_directory_symlinks_in root = let on_symlink ~dir:raw_dir name () = + let name = Filename.to_string name in let relative = Path.relative (Path.relative root raw_dir) name in let full_name = Path.to_string relative in match Fpath.follow_symlink full_name with @@ -410,6 +411,7 @@ let%test_module "resolve symlink tests" = - other (pipes, sockets, etc.): "path [kind]" *) let dump_tree root = let str ~dir fname = + let fname = Filename.to_string fname in let dir = if String.is_empty dir then root else Path.relative root dir in Path.to_string (Path.relative dir fname) in diff --git a/src/dune_pkg/lock_dir.ml b/src/dune_pkg/lock_dir.ml index b8b81c23779..41dc56fe328 100644 --- a/src/dune_pkg/lock_dir.ml +++ b/src/dune_pkg/lock_dir.ml @@ -539,11 +539,11 @@ let in_source_tree path = | In_source_tree s -> s | In_build_dir b -> let in_source = Path.drop_build_context_exn path in - (match Path.Source.explode in_source with + (match Path.Source.explode in_source |> Filename.L.to_string with | "default" :: ".lock" :: components -> Path.Source.L.relative Path.Source.root components | source_components -> - (match Path.Build.explode b with + (match Path.Build.explode b |> Filename.L.to_string with | (".dev-tools.locks" as prefix) :: dev_tool :: components -> let build_as_source = Path.build_dir |> Path.to_string |> Path.Source.of_string @@ -1232,7 +1232,7 @@ let create_latest_version } ;; -let metadata_filename = "lock.dune" +let metadata_filename = Filename.lock_dune module Metadata = Dune_sexp.Versioned_file.Make (Unit) @@ -1324,13 +1324,14 @@ module Package_filename = struct because if portable lockdirs is not enabled then we want to fall back to the behaviour where version numbers are not included in lockfile names. Make it non-optional when lockdirs become portable by default. *) - match maybe_package_version with - | None -> Package_name.to_string package_name ^ file_extension_string - | Some package_version -> - Package_name.to_string package_name - ^ "." - ^ Package_version.to_string package_version - ^ file_extension_string + (match maybe_package_version with + | None -> Package_name.to_string package_name ^ file_extension_string + | Some package_version -> + Package_name.to_string package_name + ^ "." + ^ Package_version.to_string package_version + ^ file_extension_string) + |> Filename.of_string_exn ;; let to_package_name_and_version package_filename = @@ -1341,7 +1342,9 @@ module Package_filename = struct (Filename.Extension.Or_empty.extension_exn ext) file_extension then ( - let without_extension = Filename.remove_extension package_filename in + let without_extension = + Filename.remove_extension package_filename |> Filename.to_string + in match String.lsplit2 without_extension ~on:'.' with | Some (left, right) -> Ok (Package_name.of_string left, Some (Package_version.of_string right)) @@ -1351,7 +1354,7 @@ module Package_filename = struct end let file_contents_by_path ~portable_lock_dir t = - (metadata_filename, encode_metadata ~portable_lock_dir t) + (Filename.to_string metadata_filename, encode_metadata ~portable_lock_dir t) :: (Packages.to_pkg_list t.packages |> List.map ~f:(fun (pkg : Pkg.t) -> let _loc, solved_for_platforms = t.solved_for_platforms in @@ -1360,7 +1363,8 @@ let file_contents_by_path ~portable_lock_dir t = then Package_filename.make pkg.info.name (Some pkg.info.version) else Package_filename.make pkg.info.name None in - package_filename, Pkg.encode ~portable_lock_dir ~solved_for_platforms pkg)) + ( Filename.to_string package_filename + , Pkg.encode ~portable_lock_dir ~solved_for_platforms pkg ))) ;; module Write_disk = struct @@ -1372,7 +1376,7 @@ module Write_disk = struct let check_existing_lock_dir path = match Path.stat path with | Ok { st_kind = S_DIR; _ } -> - let metadata_path = Path.relative path metadata_filename in + let metadata_path = Path.relative_fname path metadata_filename in (match Path.stat metadata_path with | Ok { st_kind = S_REG; _ } -> (match Metadata.load metadata_path ~f:(Fun.const decode_metadata) with @@ -1394,7 +1398,9 @@ module Write_disk = struct "Specified lock dir path (%s) is not a directory" (Path.to_string_maybe_quoted path) | `No_metadata_file -> - Pp.textf "Specified lock dir lacks metadata file (%s)" metadata_filename + Pp.textf + "Specified lock dir lacks metadata file (%s)" + (Filename.to_string metadata_filename) | `Failed_to_parse_metadata (path, exn) -> Pp.concat ~sep:Pp.cut @@ -1440,12 +1446,12 @@ module Write_disk = struct | Error e -> raise_user_error_on_check_existance src e | Ok `Non_existant -> () | Ok `Is_existing_lock_dir -> - let dst_of ~dir fname = Path.relative dst (Filename.concat dir fname) in + let dst_of ~dir fname = Path.relative dst (Filename.append dir fname) in Fpath.traverse ~dir:(Path.to_string src) ~init:() ~on_file:(fun ~dir fname () -> - let child_src = Path.relative src (Filename.concat dir fname) in + let child_src = Path.relative src (Filename.append dir fname) in let child_dst = dst_of ~dir fname in Path.mkdir_p (Path.relative dst dir); Io.copy_file ~src:child_src ~dst:child_dst ()) @@ -1492,7 +1498,9 @@ module Write_disk = struct = let lock_dir_hidden = (* The original lockdir path with the lockdir renamed to begin with a ".". *) - let hidden_basename = sprintf ".%s" (Path.basename lock_dir_path_external) in + let hidden_basename = + sprintf ".%s" (Path.basename lock_dir_path_external |> Filename.to_string) + in Path.relative (Path.parent_exn lock_dir_path_external) hidden_basename in let remove_hidden_dir_if_exists () = @@ -1629,7 +1637,7 @@ struct = let open Io.O in let pkg_file_path = - Path.relative + Path.relative_fname lock_dir_path (Package_filename.make package_name maybe_package_version) in @@ -1698,7 +1706,7 @@ struct , expanded_solver_variable_bindings , solved_for_platforms ) = - load_metadata (Path.relative lock_dir_path metadata_filename) + load_metadata (Path.relative_fname lock_dir_path metadata_filename) in let portable_lock_dir, solved_for_platforms = match solved_for_platforms with diff --git a/src/dune_pkg/mount.ml b/src/dune_pkg/mount.ml index d2a14aea618..5bd26eb5724 100644 --- a/src/dune_pkg/mount.ml +++ b/src/dune_pkg/mount.ml @@ -99,7 +99,7 @@ let stat t path = if Rev_store.File.Set.exists files ~f:(fun file -> let path = Rev_store.File.path file in - String.equal basename (Path.Local.basename path)) + Filename.equal basename (Path.Local.basename path)) then `File else `Absent_or_unrecognized)) ;; @@ -123,7 +123,9 @@ let readdir t dir = | S_REG -> Some `File | S_DIR -> Some `Dir | S_LNK -> - (match (Unix.stat (Path.to_string (Path.relative dir name))).st_kind with + (match + (Unix.stat (Path.to_string (Path.relative_fname dir name))).st_kind + with | S_REG -> Some `File | S_DIR -> Some `Dir | _ -> None) diff --git a/src/dune_pkg/opam_repo.ml b/src/dune_pkg/opam_repo.ml index 6bebf2fbcb7..98f3b44364a 100644 --- a/src/dune_pkg/opam_repo.ml +++ b/src/dune_pkg/opam_repo.ml @@ -216,7 +216,8 @@ let all_packages_in_dir_at_path ~dir ~path loc = let all_packages_versions_in_dir loc ~dir opam_package_name = let path = Paths.package_root opam_package_name in - all_packages_in_dir_at_path ~dir ~path loc |> List.map ~f:OpamPackage.of_string + all_packages_in_dir_at_path ~dir ~path loc + |> List.map ~f:(fun name -> OpamPackage.of_string (Filename.to_string name)) ;; let all_packages_versions_at_rev_at_path ~path rev = @@ -226,10 +227,14 @@ let all_packages_versions_at_rev_at_path ~path rev = let path = Rev_store.File.path file in let open Option.O in Path.Local.basename_opt path - >>= function + >>= fun basename -> + match Filename.to_string basename with | "opam" -> let+ package = - Path.Local.parent path >>| Path.Local.basename >>| OpamPackage.of_string + Path.Local.parent path + >>| Path.Local.basename + >>| Filename.to_string + >>| OpamPackage.of_string in file, package | _ -> None) @@ -323,7 +328,7 @@ let packages_in_repo repo = |> OpamPackage.Name.Set.elements | Directory dir -> all_packages_in_dir_at_path ~path ~dir repo.loc - |> List.map ~f:OpamPackage.Name.of_string + |> List.map ~f:(fun name -> OpamPackage.Name.of_string (Filename.to_string name)) ;; module Private = struct diff --git a/src/dune_pkg/resolved_package.ml b/src/dune_pkg/resolved_package.ml index 285b3b105c4..43c959399a5 100644 --- a/src/dune_pkg/resolved_package.ml +++ b/src/dune_pkg/resolved_package.ml @@ -87,7 +87,9 @@ let scan_files_entries path = ~dir:(Path.to_string path) ~init:[] ~f:(fun ~dir filename acc -> - let local_path = Path.Local.relative (Path.Local.of_string dir) filename in + let local_path = + Path.Local.relative_fname (Path.Local.of_string dir) filename + in local_path :: acc)) with | Unix.Unix_error (err, a, e) -> diff --git a/src/dune_pkg/workspace.ml b/src/dune_pkg/workspace.ml index 00dccef964e..f51b6345b0d 100644 --- a/src/dune_pkg/workspace.ml +++ b/src/dune_pkg/workspace.ml @@ -88,7 +88,7 @@ let dev_tool_path_to_source_dir path = "External path is not pointing to lock dir location" [ "external", Path.External.to_dyn path ] | In_build_dir b -> - (match Path.Build.explode b with + (match Path.Build.explode b |> Filename.L.to_string with | (".dev-tools.locks" as prefix) :: dev_tool_name :: components -> let build_as_source = Path.build_dir |> Path.to_string |> Path.Source.of_string in Path.Source.L.relative build_as_source (prefix :: dev_tool_name :: components) diff --git a/src/dune_rules/alias_rec.ml b/src/dune_rules/alias_rec.ml index 40a9dfecaf4..6e6a4b6ef27 100644 --- a/src/dune_rules/alias_rec.ml +++ b/src/dune_rules/alias_rec.ml @@ -18,7 +18,7 @@ module In_melange_target_dir = struct let* { Alias_build_info.alias_status; allowed_build_only_subdirs } = f dir in (* TODO there should be traversals that don't require this conversion *) Filename.Set.to_list allowed_build_only_subdirs - |> Action_builder.List.map ~f:(fun s -> fold (Path.Build.relative dir s) ~f) + |> Action_builder.List.map ~f:(fun s -> fold (Path.Build.relative_fname dir s) ~f) >>| List.fold_left ~init:alias_status ~f:Alias_builder.Alias_status.combine in fun dir ~f:dep_on_alias_if_exists -> @@ -33,7 +33,9 @@ include Alias_builder.Alias_rec (struct let open Action_builder.O in let ctx_name, src_dir = Path.Build.extract_build_context_exn dir in let f = - let build_dir = Context_name.build_dir (Context_name.of_string ctx_name) in + let build_dir = + Context_name.build_dir (Context_name.of_string (Filename.to_string ctx_name)) + in fun dir -> let build_path = Path.Build.append_source build_dir (Source_tree.Dir.path dir) diff --git a/src/dune_rules/artifact_substitution.ml b/src/dune_rules/artifact_substitution.ml index dad01930681..6f05e83e8a0 100644 --- a/src/dune_rules/artifact_substitution.ml +++ b/src/dune_rules/artifact_substitution.ml @@ -687,7 +687,7 @@ let copy_file ~conf ?chmod ?(delete_dst_if_it_is_a_directory = false) ~src ~dst file will not trigger a rebuild. *) let temp_file = let dst_dir = Path.parent_exn dst in - let dst_name = Path.basename dst in + let dst_name = Path.basename dst |> Filename.to_string in Path.relative dst_dir (sprintf ".#%s.dune-temp" dst_name) in Fiber.finalize diff --git a/src/dune_rules/artifacts.ml b/src/dune_rules/artifacts.ml index aabf43aaf63..d9bc38dacf2 100644 --- a/src/dune_rules/artifacts.ml +++ b/src/dune_rules/artifacts.ml @@ -1,8 +1,8 @@ open Import open Memo.O -let bin_dir_basename = ".bin" -let local_bin p = Path.Build.relative p bin_dir_basename +let bin_dir_basename = Filename.bin_dir_basename +let local_bin p = Path.Build.relative_fname p bin_dir_basename type origin = { binding : File_binding.Unexpanded.t @@ -47,22 +47,29 @@ let local_binaries { local_bins; _ } = ;; let analyze_binary t ~dir name = - match Filename.is_relative name with - | false -> Memo.return (`Resolved (Path.of_filename_relative_to_initial_cwd name)) - | true -> + match Filename.analyze_program_name name with + | Absolute -> Memo.return (`Resolved (Path.of_filename_relative_to_initial_cwd name)) + | (In_path | Relative_to_current_dir) as kind -> let* local_bins = Memo.Lazy.force t.local_bins in let lookup_name = - match Filename.analyze_program_name name with - | Absolute | In_path -> name - | Relative_to_current_dir -> Path.Build.relative dir name |> Path.Build.basename + match kind with + | In_path -> Filename.of_string name + | Relative_to_current_dir -> Path.Build.relative dir name |> Path.Build.basename_opt + | Absolute -> + Code_error.raise + "Artifacts.analyze_binary: unexpected absolute program name" + [ "name", Dyn.string name ] in let which () = - Context.which t.context lookup_name - >>| function - | None -> `None - | Some path -> `Resolved path + match lookup_name with + | None -> Memo.return `None + | Some lookup_name -> + Context.which t.context lookup_name + >>| (function + | None -> `None + | Some path -> `Resolved path) in - (match Filename.Map.find local_bins lookup_name with + (match Option.bind lookup_name ~f:(Filename.Map.find local_bins) with | Some (Resolved p) -> Memo.return (`Resolved (Path.build p.path)) | None -> which () | Some (Origin origins) -> @@ -137,7 +144,8 @@ let create = Memo.lazy_ (fun () -> let+ local_bins = Memo.Lazy.force local_bins in Filename.Map.to_list_map local_bins ~f:(fun name sources -> - Bin.strip_exe name, Origin (Appendable_list.to_list sources)) + ( Filename.of_string_exn (Bin.strip_exe (Filename.to_string name)) + , Origin (Appendable_list.to_list sources) )) |> Filename.Map.of_list_exn) in { context; local_bins } diff --git a/src/dune_rules/artifacts.mli b/src/dune_rules/artifacts.mli index 5ca6d6e16ac..75918ef5cbb 100644 --- a/src/dune_rules/artifacts.mli +++ b/src/dune_rules/artifacts.mli @@ -35,7 +35,7 @@ val binary -> ?where:where -> dir:Path.Build.t -> loc:Loc.t option - -> Filename.t + -> string -> Action.Prog.t Memo.t val binary_available : t -> dir:Path.Build.t -> string -> bool Memo.t diff --git a/src/dune_rules/cinaps.ml b/src/dune_rules/cinaps.ml index 1edb5b7dcf4..99cc3f2e638 100644 --- a/src/dune_rules/cinaps.ml +++ b/src/dune_rules/cinaps.ml @@ -110,7 +110,7 @@ let gen_rules sctx t ~dir ~scope = if Predicate_lang.Glob.test t.files - (Path.Source.basename p) + (Path.Source.basename p |> Filename.to_string) ~standard:Predicate_lang.true_ then Some @@ -271,7 +271,7 @@ let gen_rules sctx t ~dir ~scope = Action.diff ~optional:true (Path.build fn) - (Path.Build.extend_basename fn ~suffix:".cinaps-corrected")) + (Path.Build.extend_basename fn ~suffix:Filename.cinaps_corrected)) ]) in Super_context.add_alias_action sctx ~dir ~loc cinaps_alias action diff --git a/src/dune_rules/compile_commands.ml b/src/dune_rules/compile_commands.ml index 6a79884bf7d..e26a6e75d83 100644 --- a/src/dune_rules/compile_commands.ml +++ b/src/dune_rules/compile_commands.ml @@ -32,7 +32,10 @@ let build_c_command ~sctx ~dir ~expander ~include_flags (src : Foreign.Source.t) >>| Appendable_list.to_list in let src_relative = - Foreign.Source.path src |> Path.Build.basename |> Path.Local.of_string + Foreign.Source.path src + |> Path.Build.basename + |> Filename.to_string + |> Path.Local.of_string in { directory = Path.build dir ; file = src_relative @@ -41,7 +44,8 @@ let build_c_command ~sctx ~dir ~expander ~include_flags (src : Foreign.Source.t) [ [ Ocaml_config.c_compiler ocaml.ocaml_config ] ; args ; (let dst = - Foreign.Source.object_name src ^ Filename.Extension.to_string ext_obj + Filename.to_string (Foreign.Source.object_name src) + ^ Filename.Extension.to_string ext_obj in match ocaml.lib_config.ccomp_type with | Msvc -> [ "/Fo" ^ dst ] diff --git a/src/dune_rules/context.ml b/src/dune_rules/context.ml index 8eff8ea3c23..c70f7eacfb7 100644 --- a/src/dune_rules/context.ml +++ b/src/dune_rules/context.ml @@ -241,7 +241,7 @@ module Opam : sig end = struct let opam = Memo.Lazy.create ~name:"context-opam" (fun () -> - Which.which ~path:(Env_path.path Env.initial) "opam" + Which.which ~path:(Env_path.path Env.initial) Filename.opam >>= function | None -> Utils.program_not_found "opam" ~loc:None | Some opam -> @@ -441,7 +441,7 @@ let create (builder : Builder.t) ~(kind : Kind.t) = ~human_readable_description:(fun () -> Pp.textf "looking up binary %S in context %S" - prog + (Filename.to_string prog) (Context_name.to_string builder.name)) (fun () -> which prog diff --git a/src/dune_rules/cram/cram_exec.ml b/src/dune_rules/cram/cram_exec.ml index 6344c3169ff..717bad14c34 100644 --- a/src/dune_rules/cram/cram_exec.ml +++ b/src/dune_rules/cram/cram_exec.ml @@ -113,7 +113,7 @@ let run_expect_test file ~f = let lexbuf = Lexbuf.from_string file_contents ~fname:(Path.to_string file) in f lexbuf in - let corrected_file = Path.extend_basename file ~suffix:".corrected" in + let corrected_file = Path.extend_basename file ~suffix:Filename.corrected in Scheduler.async_exn (fun () -> if file_contents <> expected then ( @@ -522,11 +522,11 @@ let make_temp_dir ~script = let suffix = let basename = Path.basename script in let suffix = - if basename = Cram_test.fname_in_dir_test + if Filename.equal basename Cram_test.fname_in_dir_test then Path.basename (Path.parent_exn script) else basename in - "." ^ suffix + "." ^ Filename.to_string suffix in Temp.create Dir ~prefix:"dune_cram" ~suffix in @@ -565,7 +565,7 @@ let run_cram_test let metadata = let name = let base = Path.basename src in - (match String.equal base "run.t" with + (match Filename.equal base Filename.run_t with | false -> src | true -> Path.parent_exn src) |> Path.drop_build_context_exn @@ -872,7 +872,7 @@ module Diff = struct loop [] current_stanzas out |> List.rev in let expected = compose_cram_output combined in - let corrected_file = Path.extend_basename script ~suffix:".corrected" in + let corrected_file = Path.extend_basename script ~suffix:Filename.corrected in if String.equal current expected then Path.rm_rf corrected_file else Io.write_file ~binary:false corrected_file expected; diff --git a/src/dune_rules/cram/cram_rules.ml b/src/dune_rules/cram/cram_rules.ml index 7fc58aa5be9..baaf578941c 100644 --- a/src/dune_rules/cram/cram_rules.ml +++ b/src/dune_rules/cram/cram_rules.ml @@ -106,7 +106,7 @@ let test_rule | Dir d -> d.dir in let dir = Path.Source.parent_exn path in - let basename = Path.Source.basename path in + let basename = Path.Source.basename path |> Filename.to_string in Path.Source.relative dir (".cram." ^ basename)) in let script_sh = Path.Build.relative base_path "cram.sh" in @@ -165,7 +165,7 @@ let test_rule ~optional:true ~mode:Text (Path.build script) - (Path.Build.extend_basename script ~suffix:".corrected") + (Path.Build.extend_basename script ~suffix:Filename.corrected) ] |> Action.Full.make ;; @@ -387,7 +387,7 @@ let cram_tests dir = |> Filename.Array.Set.to_list |> List.filter_map ~f:(fun s -> if Cram_test.is_cram_suffix s - then Some (Ok (Cram_test.File (Path.Source.relative path s))) + then Some (Ok (Cram_test.File (Path.Source.relative_fname path s))) else None) in let+ dir_tests = @@ -401,7 +401,7 @@ let cram_tests dir = let fname = Cram_test.fname_in_dir_test in let test = let dir = Source_tree.Dir.path sub_dir in - let file = Path.Source.relative dir fname in + let file = Path.Source.relative_fname dir fname in Cram_test.Dir { file; dir } in let files = Source_tree.Dir.filenames sub_dir in diff --git a/src/dune_rules/dep_conf_eval.ml b/src/dune_rules/dep_conf_eval.ml index 3087182c66e..e785a26a024 100644 --- a/src/dune_rules/dep_conf_eval.ml +++ b/src/dune_rules/dep_conf_eval.ml @@ -119,7 +119,7 @@ let rec dir_contents ~loc d = | Ok contents -> Fs_memo.Dir_contents.to_list contents |> Memo.parallel_map ~f:(fun (entry, kind) -> - let path = Path.Outside_build_dir.relative d entry in + let path = Path.Outside_build_dir.relative d (Filename.to_string entry) in match kind with | Unix.S_REG -> Memo.return [ path ] | S_DIR -> dir_contents ~loc path diff --git a/src/dune_rules/dir_contents.ml b/src/dune_rules/dir_contents.ml index a14dadea874..e681f04714e 100644 --- a/src/dune_rules/dir_contents.ml +++ b/src/dune_rules/dir_contents.ml @@ -166,7 +166,9 @@ end = struct Path.Build.set_extension mlg_file ~ext:Filename.Extension.ml |> Path.Build.basename) | Rocq_stanza.Extraction.T s -> - Memo.return (Rocq_stanza.Extraction.target_fnames s) + Memo.return + (Rocq_stanza.Extraction.target_fnames s + |> List.map ~f:Filename.of_string_exn) | Rule_conf.T rule -> Simple_rules.user_rule sctx rule ~dir ~expander >>| (function @@ -178,7 +180,8 @@ end = struct Simple_rules.copy_files sctx def ~src_dir ~dir ~expander >>| Path.Set.to_list_map ~f:Path.basename | Generate_sites_module_stanza.T def -> - Generate_sites_module_rules.setup_rules sctx ~dir def >>| List.singleton + Generate_sites_module_rules.setup_rules sctx ~dir def + >>| fun fn -> [ Filename.of_string_exn fn ] | Library.T { buildable; _ } | Executables.T { buildable; _ } | Tests.T { exes = { buildable; _ }; _ } -> @@ -189,7 +192,8 @@ end = struct Option.map buildable.ctypes ~f:Ctypes_field.generated_ml_and_c_files |> Option.value ~default:[] in - Memo.return (select_deps_files @ ctypes_files) + Memo.return + (List.map (select_deps_files @ ctypes_files) ~f:Filename.of_string_exn) | _ -> Memo.return []) >>| List.concat >>| Filename.Array.Set.of_list diff --git a/src/dune_rules/dir_status.ml b/src/dune_rules/dir_status.ml index bfe848a09be..68149bff825 100644 --- a/src/dune_rules/dir_status.ml +++ b/src/dune_rules/dir_status.ml @@ -254,7 +254,7 @@ end = struct |> Filename.Array.Map.to_list |> Memo.parallel_map ~f:(fun (basename, st_dir) -> let* st_dir = Source_tree.Dir.sub_dir_as_t st_dir in - let dir = Path.Build.relative dir basename in + let dir = Path.Build.relative_fname dir basename in let local = basename :: local in walk st_dir ~dir ~local) >>| Appendable_list.concat @@ -320,7 +320,7 @@ end = struct Is_component_of_a_group_but_not_the_root { stanzas = None; group_root }) | Some (ctx, st_dir) -> let src_dir = Source_tree.Dir.path st_dir in - Pkg_rules.lock_dir_path (Context_name.of_string ctx) + Pkg_rules.lock_dir_path (Context_name.of_string (Filename.to_string ctx)) >>| (function | None -> false | Some of_ -> Path.is_descendant ~of_ (Path.source src_dir)) diff --git a/src/dune_rules/doc_sources.ml b/src/dune_rules/doc_sources.ml index 0e157f0bb04..069bd93d959 100644 --- a/src/dune_rules/doc_sources.ml +++ b/src/dune_rules/doc_sources.ml @@ -28,7 +28,7 @@ let of_file_bindings fbs = let path = File_binding.Expanded.src file_binding in let in_doc = match File_binding.Expanded.dst file_binding with - | None -> Path.Local.of_string (Path.Build.basename path) + | None -> Path.Local.of_string (Path.Build.basename path |> Filename.to_string) | Some in_doc -> let loc = File_binding.Expanded.src_loc file_binding in Path.Local.parse_string_exn ~loc in_doc @@ -42,7 +42,7 @@ let from_mld_files mlds (doc : Documentation.t) dir = ~standard:mlds ~key:Fun.id ~parse:(fun ~loc s -> - match Filename.Map.find mlds (s ^ ".mld") with + match String.Map.find mlds (s ^ ".mld") with | Some s -> s | None -> User_error.raise @@ -53,19 +53,20 @@ let from_mld_files mlds (doc : Documentation.t) dir = (Path.to_string_maybe_quoted (Path.drop_optional_build_context (Path.build dir))) ]) - |> Filename.Map.map ~f:(fun in_doc -> + |> String.Map.map ~f:(fun in_doc -> let path = Path.Build.relative dir in_doc in let in_doc = Path.Local.of_string in_doc in { path; in_doc }) - |> Filename.Map.values + |> String.Map.values ;; let build_mlds_map stanzas ~dir ~files expander = let mlds = lazy - (Filename.Array.Set.fold files ~init:Filename.Map.empty ~f:(fun fn acc -> + (Filename.Array.Set.fold files ~init:String.Map.empty ~f:(fun fn acc -> + let fn = Filename.to_string fn in match String.rsplit2 fn ~on:'.' with - | Some (_, "mld") -> Filename.Map.set acc fn fn + | Some (_, "mld") -> String.Map.set acc fn fn | _ -> acc)) in Dune_file.find_stanzas stanzas Documentation.key diff --git a/src/dune_rules/dune_file.ml b/src/dune_rules/dune_file.ml index 25cd859a5af..d092f44c0ca 100644 --- a/src/dune_rules/dune_file.ml +++ b/src/dune_rules/dune_file.ml @@ -113,7 +113,7 @@ let parse_stanzas ~file ~(eval : eval) sexps = | Some f -> f | None -> (* TODO this is wrong *) - Path.Source.relative eval.dir Source.Dune_file.fname + Path.Source.relative_fname eval.dir Source.Dune_file.fname in let stanza_parser = Dune_project.stanza_parser ~dir:eval.dir eval.project @@ -317,7 +317,11 @@ module Script = struct (Path.Build.relative generated_dune_files_dir (Context_name.to_string context)) file in - let wrapper = Path.Build.extend_basename generated_dune_file ~suffix:".ml" in + let wrapper = + Path.Build.extend_basename + generated_dune_file + ~suffix:(Filename.Extension.to_filename Filename.Extension.ml) + in generated_dune_file |> Path.build |> Path.parent |> Option.iter ~f:Path.mkdir_p; let* context = Context.DB.get context in let* ocaml = Context.ocaml context in @@ -431,7 +435,7 @@ module Eval = struct let origin = Path.Build.append_source (Context_name.build_dir context) - (Path.Source.relative eval.dir Source.Dune_file.fname) + (Path.Source.relative_fname eval.dir Source.Dune_file.fname) in let include_context = Include_stanza.in_build_file origin in collect_dynamic_includes eval include_context origin dynamic_includes diff --git a/src/dune_rules/dune_package.ml b/src/dune_rules/dune_package.ml index 7ec329e2a6e..f7cc7ed5788 100644 --- a/src/dune_rules/dune_package.ml +++ b/src/dune_rules/dune_package.ml @@ -138,7 +138,7 @@ module Lib = struct | None -> [] | Some stublibs -> List.map - ~f:(fun file -> Path.relative stublibs (Path.basename file)) + ~f:(fun file -> Path.relative_fname stublibs (Path.basename file)) (Lib_info.foreign_dll_files info) in record_fields diff --git a/src/dune_rules/env_stanza_db.ml b/src/dune_rules/env_stanza_db.ml index 7168696105d..c4b243aa3d5 100644 --- a/src/dune_rules/env_stanza_db.ml +++ b/src/dune_rules/env_stanza_db.ml @@ -70,7 +70,7 @@ let value ~default ~f = let profile ~dir = let name, _ = Path.Build.extract_build_context_exn dir in - let context = Context_name.of_string name in + let context = Context_name.of_string (Filename.to_string name) in Per_context.profile context ;; diff --git a/src/dune_rules/expander.ml b/src/dune_rules/expander.ml index e8bc720d302..6aaacba2849 100644 --- a/src/dune_rules/expander.ml +++ b/src/dune_rules/expander.ml @@ -187,7 +187,8 @@ let expand_artifact ~source t artifact arg = match artifact with | Pform.Artifact.Mod kind -> let name = - Module_name.of_string_allow_invalid (Dune_lang.Template.Pform.loc source, name) + Module_name.of_string_allow_invalid + (Dune_lang.Template.Pform.loc source, Filename.to_string name) |> Module_name.Unchecked.allow_invalid in (match Artifacts_obj.lookup_module artifacts name with @@ -202,7 +203,10 @@ let expand_artifact ~source t artifact arg = | None -> Action_builder.return [ Value.String "" ] | Some path -> dep (Path.build path))) | Lib mode -> - let name = Lib_name.parse_string_exn (Dune_lang.Template.Pform.loc source, name) in + let name = + Lib_name.parse_string_exn + (Dune_lang.Template.Pform.loc source, Filename.to_string name) + in (match Artifacts_obj.lookup_library artifacts name with | None -> does_not_exist ~what:"Library" (Lib_name.to_string name) | Some lib -> @@ -400,13 +404,19 @@ let expand_lib_variable t source ~lib ~file ~lib_exec ~lib_private = ] | _ -> let has_exe_ext = - let extension = Filename.extension file in + let extension = + Stdlib.Filename.extension file |> Filename.Extension.Or_empty.of_string_exn + in Filename.Extension.Or_empty.check extension Filename.Extension.exe in if (not lib_exec) || (not Sys.win32) || has_exe_ext then dep p else ( - let p_exe = Path.extend_basename p ~suffix:".exe" in + let p_exe = + Path.extend_basename + p + ~suffix:(Filename.Extension.to_filename Filename.Extension.exe) + in Action_builder.if_file_exists p_exe ~then_:(dep p_exe) ~else_:(dep p))) | Error () -> (if lib_private diff --git a/src/dune_rules/fdo.ml b/src/dune_rules/fdo.ml index 3b76097e1ac..93433805a90 100644 --- a/src/dune_rules/fdo.ml +++ b/src/dune_rules/fdo.ml @@ -8,8 +8,8 @@ type phase = let linear_ext = Filename.Extension.of_string_exn ".cmir-linear" let linear_fdo_ext = Filename.Extension.(of_string_exn (to_string linear_ext ^ "-fdo")) -let fdo_profile s = Path.extend_basename s ~suffix:".fdo-profile" -let linker_script s = Path.extend_basename s ~suffix:".linker-script" +let fdo_profile s = Path.extend_basename s ~suffix:Filename.fdo_profile +let linker_script s = Path.extend_basename s ~suffix:Filename.linker_script let phase_flags = function | None -> [] diff --git a/src/dune_rules/fetch_rules.ml b/src/dune_rules/fetch_rules.ml index 626117e0eaf..2c31de81418 100644 --- a/src/dune_rules/fetch_rules.ml +++ b/src/dune_rules/fetch_rules.ml @@ -264,6 +264,7 @@ let gen_rules_for_checksum_or_url (loc_url, (url : OpamUrl.t)) checksum = ;; let gen_rules ~dir ~components = + let components = Filename.L.to_string components in match components with | [] -> Memo.return Rules.empty @@ -271,7 +272,7 @@ let gen_rules ~dir ~components = ~build_dir_only_sub_dirs: (Gen_rules.Build_only_sub_dirs.singleton ~dir - (Subdir_set.of_list [ "checksum"; "url" ])) + (Subdir_set.of_list [ Filename.checksum; Filename.url ])) |> Memo.return | [ ("url" | "checksum") ] -> Memo.return Rules.empty @@ -318,8 +319,9 @@ module Copy = struct ~init:() ~dir:(Path.to_string src_dir) ~on_dir:(fun ~dir fname () -> - Path.L.relative dst_dir [ dir; fname ] |> Path.mkdir_p) + Path.L.relative dst_dir [ dir; Filename.to_string fname ] |> Path.mkdir_p) ~on_file:(fun ~dir fname () -> + let fname = Filename.to_string fname in let src = Path.L.relative src_dir [ dir; fname ] in let dst = Path.L.relative dst_dir [ dir; fname ] in Io.copy_file ~src ~dst ()) diff --git a/src/dune_rules/file_binding_expand.ml b/src/dune_rules/file_binding_expand.ml index a08e87b057a..a2a531fb011 100644 --- a/src/dune_rules/file_binding_expand.ml +++ b/src/dune_rules/file_binding_expand.ml @@ -3,7 +3,7 @@ open Memo.O let relative_path_starts_with_parent relative_path = match String.lsplit2 relative_path ~on:'/' with - | None -> Filename.(equal relative_path parent_dir_name) + | None -> String.equal relative_path Filename.parent_dir_name | Some (first, _) -> String.equal first Filename.parent_dir_name ;; diff --git a/src/dune_rules/findlib.ml b/src/dune_rules/findlib.ml index f6be5b83aa8..6f5ad839281 100644 --- a/src/dune_rules/findlib.ml +++ b/src/dune_rules/findlib.ml @@ -76,9 +76,10 @@ module DB = struct end let resolve_link ~dir ~fname (kind : File_kind.t) = + let fname_s = Filename.to_string fname in match kind with | S_LNK -> - (match Path.Untracked.stat (Path.relative dir fname) with + (match Path.Untracked.stat (Path.relative dir fname_s) with | Ok { Unix.st_kind; _ } -> Some st_kind | Error _ -> None) | _ -> Some kind @@ -187,7 +188,10 @@ let to_dune_library (t : Findlib.Package.t) ~dir_contents ~ext_lib ~external_loc [], [] | Ok dir_contents -> List.rev_filter_partition_map dir_contents ~f:(fun f -> - let ext = Filename.extension f in + let f = Filename.to_string f in + let ext = + Stdlib.Filename.extension f |> Filename.Extension.Or_empty.of_string_exn + in if Filename.Extension.Or_empty.check ext ext_lib then ( let file = Path.relative t.dir f in @@ -219,17 +223,18 @@ let to_dune_library (t : Findlib.Package.t) ~dir_contents ~ext_lib ~external_loc | Ok dir_contents -> let ext = Filename.Extension.to_string (Cm_kind.ext Cmi) in Result.List.filter_map dir_contents ~f:(fun fname -> - match String.ends_with ~suffix:ext fname with + let fname_s = Filename.to_string fname in + match String.ends_with ~suffix:ext fname_s with | false -> Ok None | true -> if (* We add this hack to skip manually mangled libraries *) - String.contains_double_underscore fname + String.contains_double_underscore fname_s then Ok None else ( match - let name = Filename.remove_extension fname in + let name = Filename.remove_extension fname |> Filename.to_string in Module_name.of_string_user_error (Loc.in_dir src_dir, name) with | Ok s -> Ok (Some s) @@ -296,7 +301,7 @@ module Loader = struct } let empty = { sub_dirs = Filename.Set.empty; metas = Filename.Set.empty } - let file_prefix = Findlib.Package.meta_fn ^ "." + let file_prefix = Filename.to_string Findlib.Package.meta_fn ^ "." let of_path = let impl path = @@ -308,7 +313,9 @@ module Loader = struct List.filter_partition_map contents ~f:(fun (name, kind) -> match resolve_link ~dir:path ~fname:name kind with | Some S_DIR -> Left name - | Some S_REG when String.starts_with ~prefix:file_prefix name -> Right name + | Some S_REG + when String.starts_with ~prefix:file_prefix (Filename.to_string name) -> + Right name | _ -> Skip) in Ok @@ -414,14 +421,22 @@ module Loader = struct in let* dir_contents = Findlib_dir.of_path_ignore_error findlib_dir in (* XXX DUNE4 why do we allow [META.foo] override [dune-package] file? *) - let meta_fn = Findlib_dir.file_prefix ^ Package.Name.to_string name in + let meta_fn = + Filename.add_extension + Findlib.Package.meta_fn + (Filename.Extension.of_string_exn ("." ^ Package.Name.to_string name)) + in if Filename.Set.mem dir_contents.metas meta_fn then - Path.relative findlib_dir meta_fn + Path.relative_fname findlib_dir meta_fn |> load_meta ~findlib_dir ~dir:Path.Local.root >>| Option.map ~f:Result.ok else ( - match Filename.Set.mem dir_contents.sub_dirs (Package.Name.to_string name) with + match + Filename.Set.mem + dir_contents.sub_dirs + (Filename.of_string_exn (Package.Name.to_string name)) + with | false -> Memo.return None | true -> let dir = Path.relative findlib_dir (Package.Name.to_string name) in @@ -431,7 +446,10 @@ module Loader = struct | Error _ -> [] | Ok s -> s) >>| List.filter_map ~f:(fun (name, (kind : File_kind.t)) -> - match name = Dune_package.fn || name = Findlib.Package.meta_fn with + match + String.equal (Filename.to_string name) Dune_package.fn + || Filename.equal name Findlib.Package.meta_fn + with | false -> None | true -> (match resolve_link ~dir ~fname:name kind with @@ -439,7 +457,7 @@ module Loader = struct | _ -> None)) >>| Filename.Set.of_list in - (if Filename.Set.mem files Dune_package.fn + (if Filename.Set.mem files (Filename.of_string_exn Dune_package.fn) then Path.relative dir Dune_package.fn |> Dune_package.Or_meta.load else Memo.return (Ok Dune_package.Or_meta.Use_meta)) >>= (function @@ -450,7 +468,7 @@ module Loader = struct (match Filename.Set.mem files Findlib.Package.meta_fn with | false -> Memo.return None | true -> - Path.relative dir Findlib.Package.meta_fn + Path.relative_fname dir Findlib.Package.meta_fn |> load_meta ~findlib_dir ~dir:(Path.Local.of_string (Package.Name.to_string name)) @@ -487,7 +505,8 @@ module Loader = struct let+ sub_dirs = Filename.Set.to_list sub_dirs |> Memo.List.filter_map ~f:(fun name -> - Path.L.relative dir [ name; Findlib.Package.meta_fn ] + let name = Filename.to_string name in + Path.L.relative dir [ name; Filename.to_string Findlib.Package.meta_fn ] |> Fs.file_exists >>| function | true -> Some (Package.Name.of_string name) @@ -495,7 +514,7 @@ module Loader = struct in let metas = Filename.Set.to_list_map metas ~f:(fun fn -> - String.drop_prefix ~prefix:Findlib_dir.file_prefix fn + String.drop_prefix ~prefix:Findlib_dir.file_prefix (Filename.to_string fn) |> Option.value_exn |> Package.Name.of_string) in diff --git a/src/dune_rules/foreign.ml b/src/dune_rules/foreign.ml index 7221ee98a95..02f9da20793 100644 --- a/src/dune_rules/foreign.ml +++ b/src/dune_rules/foreign.ml @@ -269,7 +269,13 @@ module Source = struct t.path |> Path.Build.split_extension |> fst |> Path.Build.basename ;; - let object_name t = user_object_name t |> add_mode_suffix (mode t) + let object_name t = + user_object_name t + |> Filename.to_string + |> add_mode_suffix (mode t) + |> Filename.of_string_exn + ;; + let make kind ~path = { kind; path } end diff --git a/src/dune_rules/foreign_rules.ml b/src/dune_rules/foreign_rules.ml index c5de56ef6a3..2eaf508878e 100644 --- a/src/dune_rules/foreign_rules.ml +++ b/src/dune_rules/foreign_rules.ml @@ -358,6 +358,7 @@ let header_files dir_contents = |> List.fold_left ~init:[] ~f:(fun acc dc -> Dir_contents.text_files dc |> Filename.Array.Set.fold ~init:acc ~f:(fun fn acc -> + let fn = Filename.to_string fn in if String.ends_with fn ~suffix:header_ext then Path.relative (Path.build (Dir_contents.dir dc)) fn :: acc else acc)) diff --git a/src/dune_rules/foreign_sources.ml b/src/dune_rules/foreign_sources.ml index 542e34784d2..d625ae26604 100644 --- a/src/dune_rules/foreign_sources.ml +++ b/src/dune_rules/foreign_sources.ml @@ -81,10 +81,11 @@ module Unresolved = struct let load ~dune_version ~dir ~files = let init = String.Map.empty in Filename.Array.Set.fold files ~init ~f:(fun fn acc -> - match drop_source_extension fn ~dune_version with + let fn_s = Filename.to_string fn in + match drop_source_extension fn_s ~dune_version with | None -> acc | Some (obj, language) -> - let path = Path.Build.relative dir fn in + let path = Path.Build.relative dir fn_s in String.Map.add_multi acc obj (language, path)) ;; @@ -140,7 +141,8 @@ let ctypes_stubs sources (ctypes : Ctypes_field.t) = (* TODO *) in let name = - Ctypes_field.c_generated_functions_cout_c ctypes fd |> Filename.remove_extension + Ctypes_field.c_generated_functions_cout_c ctypes fd + |> Stdlib.Filename.remove_extension in let path = match Unresolved.find_source sources C (loc, name) with @@ -188,7 +190,7 @@ let eval_foreign_stubs match Unresolved.find_source sources language (loc, name) with | Some path -> let src = Foreign.Source.make (Stubs stubs) ~path in - let new_key = Foreign.Source.object_name src in + let new_key = Foreign.Source.object_name src |> Filename.to_string in String.Map.add_exn acc new_key (loc, src) | None -> User_error.raise @@ -209,7 +211,7 @@ let eval_foreign_stubs in List.fold_left stub_maps ~init:String.Map.empty ~f:(fun a b -> String.Map.union a b ~f:(fun _name (loc, src1) (_, src2) -> - let name = Foreign.Source.user_object_name src1 in + let name = Foreign.Source.user_object_name src1 |> Filename.to_string in let mode = Foreign.Source.mode src1 in multiple_sources_error ~name @@ -255,7 +257,7 @@ let make stanzas ~(sources : Unresolved.t) ~dune_version = ] |> List.concat_map ~f:(fun sources -> Foreign.Sources.to_list_map sources ~f:(fun _ (loc, source) -> - Foreign.Source.object_name source, loc)) + Foreign.Source.object_name source |> Filename.to_string, loc)) in match String.Map.of_list objects with | Ok _ -> () diff --git a/src/dune_rules/format_rules.ml b/src/dune_rules/format_rules.ml index a5402a73306..bd672d5684a 100644 --- a/src/dune_rules/format_rules.ml +++ b/src/dune_rules/format_rules.ml @@ -45,7 +45,7 @@ let formatter_diff_action = and+ () = Action_builder.path (Path.build input) in Action.chdir (Path.build (Path.Build.parent_exn input)) - (let output = Path.Build.extend_basename input ~suffix:".corrected" in + (let output = Path.Build.extend_basename input ~suffix:Filename.corrected in Action.progn [ Action.write_file output formatter; Action.diff (Path.build input) output ]) |> Action.Full.make @@ -97,7 +97,9 @@ module Ocamlformat = struct and+ () = Action_builder.path (Path.build input) in Action.chdir (Path.build dir) - (Action.run (Ok path) [ flag_of_kind kind; Path.Build.basename input ]) + (Action.run + (Ok path) + [ flag_of_kind kind; Path.Build.basename input |> Filename.to_string ]) |> Action.Full.make in (* Depend on [extra_deps] so if the ocamlformat config file @@ -177,14 +179,14 @@ let setup_source_file | None -> Action_builder.return () | Some (kind, format) -> let loc = Loc.in_file (Path.source file) in - let input = Path.Build.relative dir (Path.Source.basename file) in + let input = Path.Build.relative_fname dir (Path.Source.basename file) in format_action format ~ocamlformat_is_locked ~input ~expander kind |> formatter_diff_action ~loc alias ~input ;; let setup_dune_files = let setup_dune_file ~version ~dir alias path = - let input_build = Path.Source.basename path |> Path.Build.relative dir in + let input_build = Path.Build.relative_fname dir (Path.Source.basename path) in let build = let input = Path.build input_build in let open Action_builder.O in @@ -221,7 +223,7 @@ let setup_source_files Source_tree.Dir.filenames source_dir |> Filename.Array.Set.to_list |> List.map ~f:(fun file -> - Path.Source.relative (Source_tree.Dir.path source_dir) file + Path.Source.relative_fname (Source_tree.Dir.path source_dir) file |> setup_source_file config ~dialects ~ocamlformat_is_locked ~expander ~dir alias) |> Action_builder.all_unit ;; diff --git a/src/dune_rules/gen_meta.ml b/src/dune_rules/gen_meta.ml index 49396e3af9b..dc55a1e93eb 100644 --- a/src/dune_rules/gen_meta.ml +++ b/src/dune_rules/gen_meta.ml @@ -51,7 +51,11 @@ let archives ?(preds = []) lib = let info = Lib.info lib in let archives = Lib_info.archives info in let plugins = Lib_info.plugins info in - let make ps = String.concat ~sep:" " (List.map ps ~f:Path.basename) in + let make ps = + String.concat + ~sep:" " + (List.map ps ~f:(fun p -> Path.basename p |> Filename.to_string)) + in [ archive (preds @ [ Pos "byte" ]) (make archives.byte) ; archive (preds @ [ Pos "native" ]) (make archives.native) ; plugin (preds @ [ Pos "byte" ]) (make plugins.byte) @@ -159,12 +163,12 @@ let gen_lib pub_name lib ~version = ; (match Lib_info.jsoo_runtime info with | [] -> [] | l -> - let l = List.map l ~f:Path.basename in + let l = List.map l ~f:(fun p -> Path.basename p |> Filename.to_string) in [ rule "jsoo_runtime" [] Set (String.concat l ~sep:" ") ]) ; (match Lib_info.wasmoo_runtime info with | [] -> [] | l -> - let l = List.map l ~f:Path.basename in + let l = List.map l ~f:(fun p -> Path.basename p |> Filename.to_string) in [ rule "wasmoo_runtime" [] Set (String.concat l ~sep:" ") ]) ] ;; diff --git a/src/dune_rules/gen_rules.ml b/src/dune_rules/gen_rules.ml index ce775538850..9b3e55b0c90 100644 --- a/src/dune_rules/gen_rules.ml +++ b/src/dune_rules/gen_rules.ml @@ -207,7 +207,8 @@ let define_all_alias ~dir ~project ~js_targets = assert (Path.Build.equal (Path.Build.parent_exn js_target) dir)); Predicate_lang.not (Predicate_lang.Glob.of_string_set - (String.Set.of_list_map js_targets ~f:Path.Build.basename))) + (String.Set.of_list_map js_targets ~f:(fun path -> + Path.Build.basename path |> Filename.to_string)))) in let only_generated_files = Dune_project.dune_version project >= (3, 0) in File_selector.of_predicate_lang ~dir:(Path.build dir) ~only_generated_files predicate @@ -480,7 +481,9 @@ module Automatic_subdir = struct match List.last components with | None -> Filename.Set.of_keys map | Some comp -> - if Filename.Map.mem map comp then Filename.Set.empty else Filename.Set.of_keys map + if Filename.Map.mem map (Filename.of_string_exn comp) + then Filename.Set.empty + else Filename.Set.of_keys map ;; let gen_rules ~sctx ~dir kind = @@ -579,13 +582,13 @@ let gen_rules_regular_directory (sctx : Super_context.t Memo.t) ~src_dir ~compon (* XXX sync this list with the pattern matches above. It's quite ugly we need this, we should rewrite this code to avoid this. *) Filename.Set.of_list - [ ".js" - ; "_doc" - ; "_doc_new" - ; ".ppx" - ; ".dune" - ; ".topmod" - ; Dune_lang.Oxcaml.parameterised_dir + [ Filename.js_dir_basename + ; Filename.doc_dir_basename + ; Filename.doc_new_dir_basename + ; Filename.ppx_dir_basename + ; Filename.dune_dir_basename + ; Filename.topmod_dir_basename + ; Filename.of_string_exn Dune_lang.Oxcaml.parameterised_dir ] in Filename.Set.union automatic toplevel @@ -687,7 +690,7 @@ let gen_rules ctx sctx ~dir components : Gen_rules.result Memo.t = | [ ".dune" ] -> has_rules ~dir - (Subdir_set.of_set (Filename.Set.of_list [ "cc_vendor" ])) + (Subdir_set.of_set (Filename.Set.of_list [ Filename.cc_vendor ])) (fun () -> Configurator_rules.gen_rules ctx) | parameterised_dir :: rest when String.equal parameterised_dir Dune_lang.Oxcaml.parameterised_dir -> @@ -739,7 +742,9 @@ let private_context ~dir components _ctx = let build_dir_only_sub_dirs = Gen_rules.Build_only_sub_dirs.singleton ~dir - (Subdir_set.of_list (List.rev_map contexts ~f:Context_name.to_string)) + (Subdir_set.of_list + (List.rev_map contexts ~f:(fun context_name -> + Filename.of_string_exn (Context_name.to_string context_name)))) in Gen_rules.make ~build_dir_only_sub_dirs (Memo.return Rules.empty) ;; @@ -784,7 +789,8 @@ let gen_rules ctx ~dir components = let+ context_dirs = let+ workspace = Workspace.workspace () in Workspace.build_contexts workspace - |> List.map ~f:(fun (ctx : Build_context.t) -> Context_name.to_string ctx.name) + |> List.map ~f:(fun (ctx : Build_context.t) -> + Filename.of_string_exn (Context_name.to_string ctx.name)) |> Subdir_set.of_list in Gen_rules.Build_only_sub_dirs.singleton ~dir context_dirs @@ -802,7 +808,8 @@ let gen_rules ctx ~dir components = else if Context_name.equal ctx Private_context.t.name then private_context ~dir components ctx else if Context_name.equal ctx Fetch_rules.context.name - then Fetch_rules.gen_rules ~dir ~components + then + Fetch_rules.gen_rules ~dir ~components:(List.map components ~f:Filename.of_string_exn) else let* () = raise_on_lock_dir_out_of_sync ctx in let gen_pkg_alias_rule = Pkg_rules.setup_pkg_install_alias ~dir ctx in diff --git a/src/dune_rules/glob_files_expand.ml b/src/dune_rules/glob_files_expand.ml index 83dccb00e77..11e9701574d 100644 --- a/src/dune_rules/glob_files_expand.ml +++ b/src/dune_rules/glob_files_expand.ml @@ -27,8 +27,8 @@ let get_descendants_of_relative_dir_relative_to_base_dir_local let+ rest = Memo.List.concat_map children ~f:(fun child -> get_descendants_rec - (Filename.concat relative_dir child) - (Filename.concat prefix child)) + (Filename.append relative_dir child) + (Filename.append prefix child)) in (relative_dir, prefix) :: rest in @@ -163,7 +163,8 @@ struct >>= M.List.concat_map ~f:(fun (file_selector, prefix) -> C.collect_files ~loc file_selector >>| Filename_set.filenames - >>| Filename.Array.Set.to_list_map ~f:(Filename.concat prefix)) + >>| Filename.Array.Set.to_list_map ~f:(fun filename -> + Filename.append prefix filename)) >>| List.sort ~compare:String.compare in { Expanded.matches; prefix = without_vars.prefix } diff --git a/src/dune_rules/inline_tests.ml b/src/dune_rules/inline_tests.ml index c01e8b02949..aabcff5bf10 100644 --- a/src/dune_rules/inline_tests.ml +++ b/src/dune_rules/inline_tests.ml @@ -453,7 +453,7 @@ include Sub_system.Register_end_point (struct let diffs = List.map promotion_targets ~f:(fun fn -> Path.as_in_build_dir_exn fn - |> Path.Build.extend_basename ~suffix:".corrected" + |> Path.Build.extend_basename ~suffix:Filename.corrected |> Action.diff ~optional:true fn) |> Action.concurrent in diff --git a/src/dune_rules/install_rules.ml b/src/dune_rules/install_rules.ml index 76ebad6864f..63398bd495f 100644 --- a/src/dune_rules/install_rules.ml +++ b/src/dune_rules/install_rules.ml @@ -3,9 +3,10 @@ open Memo.O let install_file ~(package : Package.Name.t) ~findlib_toolchain = let package = Package.Name.to_string package in - match findlib_toolchain with - | None -> package ^ ".install" - | Some x -> sprintf "%s-%s.install" package (Context_name.to_string x) + (match findlib_toolchain with + | None -> package ^ ".install" + | Some x -> sprintf "%s-%s.install" package (Context_name.to_string x)) + |> Filename.of_string_exn ;; let with_doc = Package_variable_name.with_doc @@ -71,7 +72,7 @@ module Package_paths = struct ;; let meta_template ctx pkg = - Path.Build.extend_basename (meta_file ctx pkg) ~suffix:".template" + Path.Build.extend_basename (meta_file ctx pkg) ~suffix:Filename.template ;; end @@ -185,7 +186,7 @@ end = struct (let dst = match dst with | Some s -> s - | None -> Path.Build.basename fn + | None -> Path.Build.basename fn |> Filename.to_string in match in_sub_dir sub_dir with | None -> dst @@ -266,10 +267,12 @@ end = struct Melange.Install.maybe_prepend_melange_install_dir ~for_ base |> Option.map ~f:Path.Local.to_string in - subdir, Some (Path.Local.basename p) + subdir, Some (Path.Local.basename p |> Filename.to_string) | None -> let dst = - Path.Build.basename source |> String.drop_suffix ~suffix:"-gen" + Path.Build.basename source + |> Filename.to_string + |> String.drop_suffix ~suffix:"-gen" in let sub_dir = let base = @@ -647,7 +650,7 @@ end = struct let file local_file install_fn = file Lib_root local_file (Package.Name.to_string name ^ "/" ^ install_fn) in - [ file meta_file Dune_findlib.Package.meta_fn + [ file meta_file (Dune_findlib.Package.meta_fn |> Filename.to_string) ; file dune_package_file Dune_package.fn ]) in @@ -658,7 +661,7 @@ end = struct | None -> [] | Some config_file -> [ file Doc config_file "odoc-config.sexp" ] in - (file Lib meta_file Dune_findlib.Package.meta_fn + (file Lib meta_file (Dune_findlib.Package.meta_fn |> Filename.to_string) :: file Lib dune_package_file Dune_package.fn :: odoc_config_file) @ @@ -674,9 +677,9 @@ end = struct let pkg_dir = Path.Build.append_source ctx.build_dir pkg_dir in Source_tree.Dir.filenames dir |> Filename.Array.Set.fold ~init ~f:(fun fn acc -> - if is_odig_doc_file fn + if is_odig_doc_file (Filename.to_string fn) then ( - let odig_file = Path.Build.relative pkg_dir fn in + let odig_file = Path.Build.relative_fname pkg_dir fn in let entry = Install.Entry.Unexpanded.make Doc @@ -1204,7 +1207,7 @@ let packages_file_is_part_of path = Memo.Option.bind (let open Option.O in let* ctx_name, _ = Path.Build.extract_build_context path in - Context_name.of_string_opt ctx_name) + Context_name.of_string_opt (Filename.to_string ctx_name)) ~f:Super_context.find >>= function | None -> Memo.return Package.Id.Set.empty @@ -1298,7 +1301,7 @@ struct ~dir:(Path.to_string entry.src) ~init:[] ~on_file:(fun ~dir fname acc -> - let file = Filename.concat dir fname in + let file = Filename.append dir fname in let path = Path.relative entry.src file in let comps = Path.Local.of_string file |> Path.Local.explode in (path, comps) :: acc) @@ -1416,7 +1419,7 @@ let gen_package_install_file_rules sctx (package : Package.t) = let action = let findlib_toolchain = Context.findlib_toolchain context in let install_file = - Path.Build.relative + Path.Build.relative_fname pkg_build_dir (install_file ~package:package_name ~findlib_toolchain) in @@ -1539,7 +1542,7 @@ let gen_install_alias sctx (package : Package.t) = in let path = Package_paths.build_dir (Context.build_context context) package in let install_alias = Alias.make Alias0.install ~dir:path in - let install_file = Path.relative (Path.build path) install_fn in + let install_file = Path.relative_fname (Path.build path) install_fn in Rules.Produce.Alias.add_deps install_alias (Action_builder.path install_file)) ;; diff --git a/src/dune_rules/jsoo/jsoo_archive_rules.ml b/src/dune_rules/jsoo/jsoo_archive_rules.ml index 03cd26f07d6..1c4a66af76f 100644 --- a/src/dune_rules/jsoo/jsoo_archive_rules.ml +++ b/src/dune_rules/jsoo/jsoo_archive_rules.ml @@ -83,13 +83,13 @@ end let parse_lib_archive_dir dir = let jsoo_dir_config = match Path.Build.basename dir with - | s when Obj_dir.is_jsoo_dirname s -> Some (dir, None) + | s when Obj_dir.is_jsoo_dirname (Filename.to_string s) -> Some (dir, None) | config -> (match Path.Build.parent dir with | Some parent when (not (Path.Build.is_root parent)) - && Obj_dir.is_jsoo_dirname (Path.Build.basename parent) -> - Some (parent, Some config) + && Obj_dir.is_jsoo_dirname (Path.Build.basename parent |> Filename.to_string) + -> Some (parent, Some (Filename.to_string config)) | _ -> None) in match jsoo_dir_config with @@ -99,7 +99,7 @@ let parse_lib_archive_dir dir = (* The "..objs" convention comes from [Obj_dir.Paths.library_object_directory]. *) let lib_name = - String.drop_prefix (Path.Build.basename obj_dir) ~prefix:"." + String.drop_prefix (Path.Build.basename obj_dir |> Filename.to_string) ~prefix:"." |> Option.bind ~f:(String.drop_suffix ~suffix:".objs") in Option.map lib_name ~f:(fun lib_name -> diff --git a/src/dune_rules/jsoo/jsoo_rules.ml b/src/dune_rules/jsoo/jsoo_rules.ml index 50ce4433c31..afad9f82dbc 100644 --- a/src/dune_rules/jsoo/jsoo_rules.ml +++ b/src/dune_rules/jsoo/jsoo_rules.ml @@ -673,7 +673,8 @@ let exe_rule ;; let with_js_ext ~mode s = - let name, ext = Filename.split_extension s in + let ext = Stdlib.Filename.extension s |> Filename.Extension.Or_empty.of_string_exn in + let name = Stdlib.Filename.remove_extension s in let ext = Filename.Extension.Or_empty.extension_exn ext in if Filename.Extension.equal ext Filename.Extension.cma then name ^ Filename.Extension.to_string (Js_of_ocaml.Ext.cma ~mode) @@ -692,7 +693,7 @@ let jsoo_archives ~mode ctx config lib = in_obj_dir' ~obj_dir ~config:(Some config) - [ with_js_ext ~mode (Path.basename archive) ]) + [ with_js_ext ~mode (Path.basename archive |> Filename.to_string) ]) | false -> List.map archives.byte ~f:(fun archive -> Path.build @@ -700,7 +701,7 @@ let jsoo_archives ~mode ctx config lib = ctx ~config [ Lib_name.to_string (Lib.name lib) - ; with_js_ext ~mode (Path.basename archive) + ; with_js_ext ~mode (Path.basename archive |> Filename.to_string) ])) ;; @@ -846,7 +847,7 @@ let build_cm' let build_from_cm sctx ~dir ~in_context ~mode ~src ~obj_dir ~shapes ~config ~sourcemap = let target = - let name = with_js_ext ~mode (Path.basename src) in + let name = with_js_ext ~mode (Path.basename src |> Filename.to_string) in in_obj_dir ~obj_dir ~config [ name ] in build_cm' @@ -991,13 +992,14 @@ let setup_separate_compilation_rules sctx components = Memo.parallel_iter archives ~f:(fun fn -> let build_context = Context.build_context ctx in let name = Path.basename fn in + let name_s = Filename.to_string name in let dir = in_build_dir build_context ~config [ lib_name ] in let src = let src_dir = Lib_info.src_dir info in - Path.relative src_dir name + Path.relative src_dir name_s in let target = - in_build_dir build_context ~config [ lib_name; with_js_ext ~mode name ] + in_build_dir build_context ~config [ lib_name; with_js_ext ~mode name_s ] in let shapes = let open Action_builder.O in @@ -1217,6 +1219,7 @@ let build_exe ~config:None [ Path.Build.basename (Path.Build.set_extension src ~ext:(Js_of_ocaml.Ext.runtime ~mode)) + |> Filename.to_string ] in Action_builder.return (Command.Args.Dep (Path.build path)), Some path diff --git a/src/dune_rules/lib.ml b/src/dune_rules/lib.ml index cce84d0e828..a0b2cdd0cd2 100644 --- a/src/dune_rules/lib.ml +++ b/src/dune_rules/lib.ml @@ -508,7 +508,10 @@ let is_local t = (match Path.Build.extract_build_context dir with | None -> true | Some (name, _) -> - not (Context_name.equal (Context_name.of_string name) Private_context.t.name)) + not + (Context_name.equal + (Context_name.of_string (Filename.to_string name)) + Private_context.t.name)) ;; let resolve_main_module_name t = diff --git a/src/dune_rules/lib_flags.ml b/src/dune_rules/lib_flags.ml index bd07736aae9..b9b6d7a9c6d 100644 --- a/src/dune_rules/lib_flags.ml +++ b/src/dune_rules/lib_flags.ml @@ -67,13 +67,16 @@ module Link_params = struct (match mode with | Byte_for_jsoo | Byte | Byte_with_stubs_statically_linked_in -> let cmo_ext = Filename.Extension.to_string (Cm_kind.ext Cmo) in - Path.extend_basename obj_name ~suffix:cmo_ext :: hidden_deps + Path.extend_basename obj_name ~suffix:(Filename.of_string_exn cmo_ext) + :: hidden_deps | Native -> let cmx_ext = Filename.Extension.to_string (Cm_kind.ext Cmx) in - Path.extend_basename obj_name ~suffix:cmx_ext + Path.extend_basename obj_name ~suffix:(Filename.of_string_exn cmx_ext) :: Path.extend_basename obj_name - ~suffix:(Filename.Extension.to_string lib_config.ext_obj) + ~suffix: + (Filename.of_string_exn + (Filename.Extension.to_string lib_config.ext_obj)) :: hidden_deps) in { deps; hidden_deps; include_dirs } diff --git a/src/dune_rules/lib_info.ml b/src/dune_rules/lib_info.ml index 9b6ecd8dbf9..7dd42bf21f5 100644 --- a/src/dune_rules/lib_info.ml +++ b/src/dune_rules/lib_info.ml @@ -709,7 +709,7 @@ let for_dune_package if Path.is_managed p then ( match kind with - | Install.Entry.Expanded.File -> Path.relative dir (Path.basename p) + | Install.Entry.Expanded.File -> Path.relative_fname dir (Path.basename p) | Directory -> dir) else p) ;; diff --git a/src/dune_rules/lock_dir.ml b/src/dune_rules/lock_dir.ml index 33e67029819..36b81714fc9 100644 --- a/src/dune_rules/lock_dir.ml +++ b/src/dune_rules/lock_dir.ml @@ -109,7 +109,12 @@ module Load = Make_load (struct | Error _ -> (* CR-someday rgrinberg: add some proper message here *) User_error.raise [ Pp.text "" ] - | Ok content -> return content + | Ok content -> + let content = + Stdune.List.map content ~f:(fun (name, kind) -> + Filename.of_string_exn name, kind) + in + return content ;; let with_lexbuf_from_file path ~f = diff --git a/src/dune_rules/lock_rules.ml b/src/dune_rules/lock_rules.ml index d6e3b4cd0ab..a9806ba68a0 100644 --- a/src/dune_rules/lock_rules.ml +++ b/src/dune_rules/lock_rules.ml @@ -443,7 +443,7 @@ let scan_lock_directory = ~empty:Path.Set.empty ~combine:Path.Set.union ~f:(fun (entry, kind) -> - let path = Path.Outside_build_dir.relative dir entry in + let path = Path.Outside_build_dir.relative_fname dir entry in match (kind : File_kind.t) with | S_REG -> Memo.return (Path.Set.singleton (Path.outside_build_dir path)) | S_DIR -> scan path @@ -518,7 +518,7 @@ let setup_rules ~components ~dir = let+ dev_tool_rules = setup_dev_tool_lock_rules ~dir dev_tool in Gen_rules.combine rules dev_tool_rules) | [] -> - let sub_dirs = [ ".lock"; ".dev-tool-locks" ] in + let sub_dirs = [ Filename.lock_dir_basename; Filename.dev_tool_locks_dir_basename ] in let build_dir_only_sub_dirs = Gen_rules.Build_only_sub_dirs.singleton ~dir @@ Subdir_set.of_list sub_dirs in diff --git a/src/dune_rules/make_prog.ml b/src/dune_rules/make_prog.ml index 2d22d00113a..3233932d971 100644 --- a/src/dune_rules/make_prog.ml +++ b/src/dune_rules/make_prog.ml @@ -4,11 +4,11 @@ open Memo.O let which loc context ~path = (let which = Which.which ~path in match Sys.unix with - | false -> which "make" + | false -> which Filename.make | true -> - which "gmake" + which Filename.gmake >>= (function - | None -> which "make" + | None -> which Filename.make | Some _ as s -> Memo.return s)) >>| function | Some p -> p diff --git a/src/dune_rules/mdx.ml b/src/dune_rules/mdx.ml index e49ff88c2d3..2a077ee2b74 100644 --- a/src/dune_rules/mdx.ml +++ b/src/dune_rules/mdx.ml @@ -18,14 +18,16 @@ module Files = struct } let corrected_file build_path = - Path.Build.extend_basename ~suffix:".corrected" build_path + Path.Build.extend_basename ~suffix:Filename.corrected build_path ;; - let deps_file build_path = Path.Build.extend_basename ~suffix:".mdx.deps" build_path + let deps_file build_path = + Path.Build.extend_basename ~suffix:Filename.mdx_deps build_path + ;; let from_source_file ~mdx_dir src = let dot_mdx_path = - let basename = Path.Build.basename src in + let basename = Path.Build.basename src |> Filename.to_string in Path.Build.relative mdx_dir basename in let deps = deps_file dot_mdx_path in @@ -290,7 +292,7 @@ let () = stanza and context *) let files_to_mdx t ~sctx ~dir = let must_mdx src_path = - let file = Path.Source.basename src_path in + let file = Path.Source.basename src_path |> Filename.to_string in let standard = default_files_of_version t.version in Predicate_lang.Glob.test t.files ~standard file in diff --git a/src/dune_rules/melange/melange_rules.ml b/src/dune_rules/melange/melange_rules.ml index 521f206411c..e8a8e14e2b0 100644 --- a/src/dune_rules/melange/melange_rules.ml +++ b/src/dune_rules/melange/melange_rules.ml @@ -93,7 +93,8 @@ let make_js_name ~js_ext ~output m = (src_dir |> Path.as_in_build_dir_exn |> Path.Build.drop_build_context_exn) in let basename = - Module_compilation.melange_js_basename m ^ Filename.Extension.to_string js_ext + Filename.to_string (Module_compilation.melange_js_basename m) + ^ Filename.Extension.to_string js_ext in Path.Build.relative dst_dir basename ;; @@ -1163,7 +1164,8 @@ let setup_emit_js_rules sctx ~dir = | Some dune_file -> let+ build_dir_only_sub_dirs = Dune_file.find_stanzas dune_file Melange_stanzas.Emit.key - >>| List.map ~f:(fun (mel : Melange_stanzas.Emit.t) -> mel.target) + >>| List.map ~f:(fun (mel : Melange_stanzas.Emit.t) -> + Filename.of_string_exn mel.target) >>| Subdir_set.of_list >>| Gen_rules.Build_only_sub_dirs.singleton ~dir in diff --git a/src/dune_rules/menhir/menhir_rules.ml b/src/dune_rules/menhir/menhir_rules.ml index e553b09b95c..c9986544de8 100644 --- a/src/dune_rules/menhir/menhir_rules.ml +++ b/src/dune_rules/menhir/menhir_rules.ml @@ -198,7 +198,9 @@ module Run (P : PARAMS) = struct match stanza.merge_into with | None -> Path.Set.fold deps ~init:[] ~f:(fun p acc -> - let merge_into = Filename.remove_extension (Path.basename p) in + let merge_into = + Path.basename p |> Filename.remove_extension |> Filename.to_string + in ({ stanza with merge_into = Some merge_into }, Path.Set.singleton p) :: acc) | Some _ -> [ stanza, deps ]) ;; diff --git a/src/dune_rules/merlin/merlin.ml b/src/dune_rules/merlin/merlin.ml index 3d282eb5e1e..652fae439a4 100644 --- a/src/dune_rules/merlin/merlin.ml +++ b/src/dune_rules/merlin/merlin.ml @@ -4,7 +4,7 @@ open Memo.O let remove_extension file = let dir = Path.Build.parent_exn file in let basename = - let basename = Path.Build.basename file in + let basename = Path.Build.basename file |> Filename.to_string in match String.lsplit2 basename ~on:'.' with | Some (basename, _ext) -> basename | None -> basename @@ -145,7 +145,10 @@ module Processed = struct Json.assoc [ "module_name", Json.string (Module_name.to_string module_name) ; ( "source_path" - , Json.string (Filename.concat context (Path.Source.to_string source_path)) ) + , Json.string + (Filename.concat + (Filename.to_string context) + (Path.Source.to_string source_path)) ) ; "config", sexp_to_json config ] ;; diff --git a/src/dune_rules/merlin/merlin_ident.ml b/src/dune_rules/merlin/merlin_ident.ml index 235555a94bf..c1333cd187d 100644 --- a/src/dune_rules/merlin/merlin_ident.ml +++ b/src/dune_rules/merlin/merlin_ident.ml @@ -19,8 +19,9 @@ let to_string = function | Melange_entries name -> sprintf "melange-%s" name ;; -let merlin_folder_name = ".merlin-conf" +let merlin_folder_name = Filename.merlin_conf_dir_basename let merlin_file_path path ident = - Filename.concat merlin_folder_name (to_string ident) |> Path.Build.relative path + Filename.concat (Filename.to_string merlin_folder_name) (to_string ident) + |> Path.Build.relative path ;; diff --git a/src/dune_rules/ml_sources.ml b/src/dune_rules/ml_sources.ml index da9c3bc7130..31cb6bab880 100644 --- a/src/dune_rules/ml_sources.ml +++ b/src/dune_rules/ml_sources.ml @@ -238,6 +238,7 @@ let modules_of_files ~dialects ~dir ~files = in let loc = Loc.in_dir dir in List.filter_partition_map (Filename.Array.Set.to_list files) ~f:(fun fn -> + let fn = Filename.to_string fn in (* we aren't using Filename.extension because we want to ignore filenames such as `foo.cppo.ml` or `foo.{filter}.ml` (e.g. from the `(select ..)` field) *) @@ -290,6 +291,7 @@ let melange_modules_of_files ~root_dir ~dialects ~dir ~files = in let loc = Loc.in_dir (Path.build dir) in List.filter_partition_map (Filename.Array.Set.to_list files) ~f:(fun fn -> + let fn = Filename.to_string fn in (* we aren't using Filename.extension because we want to handle filenames such as foo.cppo.ml *) match String.lsplit2 fn ~on:'.' with @@ -914,10 +916,13 @@ module Generated_modules = struct ~loc:(Some loc) ~include_subdirs ~dir - (Path.Local.parent_exn descendant |> Path.Local.explode) + (Path.Local.parent_exn descendant + |> Path.Local.explode + |> Filename.L.to_string) in let module_name = - Module_name.of_string_allow_invalid (loc, basename) + Module_name.of_string_allow_invalid + (loc, Filename.to_string basename) |> Module_name.Unchecked.validate_exn in Nonempty_list.(base_path @ [ Module_name.unchecked module_name ]) @@ -1012,7 +1017,11 @@ module Generated_modules = struct | false -> Memo.return `Skip | true -> let module_path = - module_path ~loc:None ~include_subdirs ~dir path_to_root + module_path + ~loc:None + ~include_subdirs + ~dir + (Filename.L.to_string path_to_root) in (match Stanza.repr stanza with | Parser_generators.Stanzas.Ocamllex.T ocamllex -> @@ -1279,7 +1288,13 @@ let make ~init:Module_trie.Unchecked.empty ~f:(fun acc { Source_file_dir.dir; files; path_to_root; _ } -> match - let path = module_path ~loc:None ~include_subdirs ~dir path_to_root in + let path = + module_path + ~loc:None + ~include_subdirs + ~dir + (Filename.L.to_string path_to_root) + in let modules = modules_of_files ~root_dir ~dialects ~dir ~files ~path ~for_ in diff --git a/src/dune_rules/module.ml b/src/dune_rules/module.ml index 9d08fe78cc6..6fb99645dc1 100644 --- a/src/dune_rules/module.ml +++ b/src/dune_rules/module.ml @@ -420,7 +420,7 @@ let ml_source = | None -> f | Some suffix -> let path = - Path.extend_basename f.path ~suffix:(Filename.Extension.to_string suffix) + Path.extend_basename f.path ~suffix:(Filename.Extension.to_filename suffix) in { f with dialect = Dialect.ocaml; path }) ;; diff --git a/src/dune_rules/module_compilation.ml b/src/dune_rules/module_compilation.ml index d73cef2d651..fc5bcee741c 100644 --- a/src/dune_rules/module_compilation.ml +++ b/src/dune_rules/module_compilation.ml @@ -118,12 +118,12 @@ let melange_js_basename m = | Some s -> (* we aren't using Filename.extension because we want to handle filenames such as foo.pp.ml *) - (match String.lsplit2 (Path.basename s) ~on:'.' with + (match String.lsplit2 (Path.basename s |> Filename.to_string) ~on:'.' with | None -> Code_error.raise "could not extract module name from file path" [ "module", Module.to_dyn m ] - | Some (module_name, _) -> module_name) + | Some (module_name, _) -> Filename.of_string_exn module_name) | None -> Code_error.raise "could not find melange source from module" @@ -177,14 +177,14 @@ let melange_args (cctx : Compilation_context.t) (cm_kind : Lib_mode.Cm_kind.t) m :: A "--mel-package-output" :: Command.Args.Path mel_package_output :: A "--mel-module-name" - :: A (melange_js_basename module_) + :: A (melange_js_basename module_ |> Filename.to_string) :: mel_package_name else Command.Args.A "--bs-stop-after-cmj" :: A "--bs-package-output" :: Command.Args.Path mel_package_output :: A "--bs-module-name" - :: A (melange_js_basename module_) + :: A (melange_js_basename module_ |> Filename.to_string) :: mel_package_name ;; diff --git a/src/dune_rules/ocaml_toolchain.ml b/src/dune_rules/ocaml_toolchain.ml index e33254d07d2..443ff5ff465 100644 --- a/src/dune_rules/ocaml_toolchain.ml +++ b/src/dune_rules/ocaml_toolchain.ml @@ -117,13 +117,13 @@ let of_env_with_findlib name env findlib_config ~which = get_tool_using_findlib_config program >>= function | Some x -> Memo.return (Some x) - | None -> which program + | None -> which (Filename.of_string_exn program) in let get_ocaml_tool ~dir prog = get_tool_using_findlib_config prog >>= function | Some x -> Memo.return (Some x) - | None -> Which.best_in_dir ~dir prog + | None -> Which.best_in_dir ~dir (Filename.of_string_exn prog) in make name ~env ~get_ocaml_tool ~which ;; @@ -135,6 +135,7 @@ let of_binaries ~path name env binaries = |> Filename.Map.of_list_map_exn ~f:(fun binary -> Path.basename binary, binary) in fun basename -> + let basename = Filename.of_string_exn basename in match Which.candidates basename |> List.find_map ~f:(Filename.Map.find map) with | Some s -> Memo.return (Some s) | None -> Which.which ~path basename diff --git a/src/dune_rules/ocamldep.ml b/src/dune_rules/ocamldep.ml index 7947b1b14a1..861a7111928 100644 --- a/src/dune_rules/ocamldep.ml +++ b/src/dune_rules/ocamldep.ml @@ -41,7 +41,8 @@ let parse_deps_exn ~file lines = | None -> invalid_ocamldep_output file lines | Some (basename, deps) -> let basename = Filename.basename basename in - if basename <> Path.basename file then invalid_ocamldep_output file lines; + if basename <> (Path.basename file |> Filename.to_string) + then invalid_ocamldep_output file lines; String.extract_blank_separated_words deps) ;; diff --git a/src/dune_rules/odoc.ml b/src/dune_rules/odoc.ml index db550b6108b..37e9c8765d0 100644 --- a/src/dune_rules/odoc.ml +++ b/src/dune_rules/odoc.ml @@ -161,7 +161,7 @@ module Output_format = struct let base = Paths.toplevel_index ctx in match format with | Html -> base - | Json -> Path.Build.extend_basename base ~suffix:".json" + | Json -> Path.Build.extend_basename base ~suffix:Filename.json | Markdown -> Paths.markdown_index ctx ;; end @@ -697,7 +697,9 @@ let create_odoc ctx ~target odoc_file = let html_base = Paths.html ctx target in let markdown_base = Paths.markdown ctx target in let odocl_base = Paths.odocl ctx target in - let basename = Path.Build.basename odoc_file |> Filename.remove_extension in + let basename = + Path.Build.basename odoc_file |> Filename.remove_extension |> Filename.to_string + in let odocl_file = odocl_base ++ (basename ^ ".odocl") in match target with | Lib _ -> @@ -706,10 +708,12 @@ let create_odoc ctx ~target odoc_file = match output with | Output_format.Html | Json -> html_dir ++ "index" - |> Path.Build.extend_basename ~suffix:(Output_format.extension output) + |> Path.Build.extend_basename + ~suffix:(Filename.of_string_exn (Output_format.extension output)) | Markdown -> markdown_base ++ Stdune.String.capitalize basename - |> Path.Build.extend_basename ~suffix:(Output_format.extension output) + |> Path.Build.extend_basename + ~suffix:(Filename.of_string_exn (Output_format.extension output)) in { odoc_file ; odocl_file @@ -725,7 +729,8 @@ let create_odoc ctx ~target odoc_file = | Html | Json -> html_base in base ++ (basename |> String.drop_prefix ~prefix:"page-" |> Option.value_exn) - |> Path.Build.extend_basename ~suffix:(Output_format.extension output) + |> Path.Build.extend_basename + ~suffix:(Filename.of_string_exn (Output_format.extension output)) in { odoc_file ; odocl_file @@ -738,7 +743,7 @@ let create_odoc ctx ~target odoc_file = let check_mlds_no_dupes ~pkg ~mlds = match List.rev_map mlds ~f:(fun ((_path, mld_name) as mld) -> mld_name, mld) - |> Filename.Map.of_list + |> String.Map.of_list with | Ok m -> m | Error (_, (p1, _name1), (p2, _name2)) -> @@ -776,7 +781,7 @@ let mlds sctx pkg = | [ name ] -> let ext = Filename.extension name in if Filename.Extension.Or_empty.check ext mld_ext - then Left (mld.path, Filename.remove_extension name) + then Left (mld.path, Filename.remove_extension name |> Filename.to_string) else Right mld | _ -> Right mld) ;; @@ -789,11 +794,11 @@ let odoc_artefacts sctx target = let+ mlds = let+ mlds, _ = mlds sctx pkg in let mlds = check_mlds_no_dupes ~pkg ~mlds in - Filename.Map.update mlds "index" ~f:(function + String.Map.update mlds "index" ~f:(function | None -> Some (Paths.gen_mld_dir ctx pkg ++ "index.mld", "index") | Some _ as s -> s) in - Filename.Map.to_list_map mlds ~f:(fun _ (path, name) -> + String.Map.to_list_map mlds ~f:(fun _ (path, name) -> Mld.create ~path ~name |> Mld.odoc_file ~doc_dir:dir |> create_odoc ctx ~target) | Lib lib -> let info = Lib.Local.info lib in @@ -1122,7 +1127,7 @@ let package_mlds = report_warnings warnings; let mlds = check_mlds_no_dupes ~pkg ~mlds in let ctx = Super_context.context sctx in - if Filename.Map.mem mlds "index" + if String.Map.mem mlds "index" then Memo.return mlds else ( let gen_mld = Paths.gen_mld_dir ctx pkg ++ "index.mld" in @@ -1132,7 +1137,7 @@ let package_mlds = sctx (Action_builder.write_file gen_mld (default_index ~pkg entry_modules)) in - Filename.Map.set mlds "index" (gen_mld, "index")))) + String.Map.set mlds "index" (gen_mld, "index")))) in fun sctx ~pkg -> Memo.exec memo (sctx, pkg) ;; @@ -1143,7 +1148,7 @@ let setup_package_odoc_rules sctx ~pkg = (* CR-someday jeremiedimino: it is weird that we drop the [Package.t] and go back to a package name here. Need to try and change that one day. *) let* odocs = - Filename.Map.values mlds + String.Map.values mlds |> Memo.parallel_map ~f:(fun (path, name) -> compile_mld sctx diff --git a/src/dune_rules/odoc_new.ml b/src/dune_rules/odoc_new.ml index fdb811350f3..3d71b49a04f 100644 --- a/src/dune_rules/odoc_new.ml +++ b/src/dune_rules/odoc_new.ml @@ -169,7 +169,10 @@ module Index = struct in let s = Path.Local.explode local in let index = - List.fold_left s ~f:(fun acc s -> Sub_dir s :: acc) ~init:[ Top_dir top ] + List.fold_left + s + ~f:(fun acc s -> Sub_dir (Filename.to_string s) :: acc) + ~init:[ Top_dir top ] in Some index ;; @@ -713,11 +716,16 @@ end = struct let reference v = match v.ty with | Mld -> - let basename = Path.basename v.source |> Filename.remove_extension in + let basename = + Path.basename v.source |> Filename.remove_extension |> Filename.to_string + in sprintf "page-\"%s\"" basename | Module _ -> let basename = - Path.basename v.source |> Filename.remove_extension |> Stdune.String.capitalize + Path.basename v.source + |> Filename.remove_extension + |> Filename.to_string + |> Stdune.String.capitalize in sprintf "module-%s" basename ;; @@ -726,7 +734,10 @@ end = struct match v.ty with | Module _ -> let basename = - Path.basename v.source |> Filename.remove_extension |> Stdune.String.capitalize + Path.basename v.source + |> Filename.remove_extension + |> Filename.to_string + |> Stdune.String.capitalize in Some (Module_name.of_string_allow_invalid (Loc.none, basename) @@ -734,12 +745,15 @@ end = struct | _ -> None ;; - let name v = Path.basename v.source |> Filename.remove_extension + let name v = Path.basename v.source |> Filename.remove_extension |> Filename.to_string let v ~source ~odoc ~html_dir ~html_file ~ty = { source; odoc; html_dir; html_file; ty } let make_module ctx ~all index source ~visible = let basename = - Path.basename source |> Filename.remove_extension |> Stdune.String.uncapitalize + Path.basename source + |> Filename.remove_extension + |> Filename.to_string + |> Stdune.String.uncapitalize in let odoc = Index.odoc_dir ctx ~all index ++ (basename ^ ".odoc") in let html_dir = Index.html_dir ctx ~all index ++ Stdune.String.capitalize basename in @@ -772,7 +786,7 @@ end = struct let dir = Index.obj_dir ctx ~all index in Path.build (dir ++ filename) in - let name = Filename.remove_extension filename in + let name = Stdlib.Filename.remove_extension filename in int_make_mld ctx ~all index source ~name ~is_index:true ;; end @@ -1156,24 +1170,36 @@ let compile_odocs sctx ~all ~quiet artifacts parent libs = inside. This is used in the fallback case where we don't know what modules there are in a particular switch directory. *) let modules_of_dir d : (Module_name.t * (Path.t * [ `Cmti | `Cmt | `Cmi ])) list Memo.t = - let extensions = [ ".cmti", `Cmti; ".cmt", `Cmt; ".cmi", `Cmi ] in + let extensions = + [ Filename.Extension.cmti, `Cmti + ; Filename.Extension.cmt, `Cmt + ; Filename.Extension.cmi, `Cmi + ] + in + let ty_of_ext ext = + List.find_map extensions ~f:(fun (ext', ty) -> + Option.some_if (Filename.Extension.equal ext ext') ty) + in Fs_memo.dir_contents (Path.as_outside_build_dir_exn d) >>| function | Error _ -> [] | Ok dc -> let list = Fs_memo.Dir_contents.to_list dc in List.filter_map list ~f:(fun (x, ty) -> - let ext = Filename.Extension.Or_empty.to_string (Filename.extension x) in - match ty, List.assoc extensions ext with - | Unix.S_REG, Some _ -> Some (Filename.remove_extension x) + match ty, Filename.extension x |> Filename.Extension.Or_empty.extension with + | Unix.S_REG, Some ext when Option.is_some (ty_of_ext ext) -> + Some (Filename.remove_extension x) | _, _ -> None) - |> List.sort_uniq ~compare:String.compare + |> List.sort_uniq ~compare:Filename.compare |> List.map ~f:(fun m -> let ext, ty = List.find_exn extensions ~f:(fun (ext, _ty) -> - List.exists list ~f:(fun (n, _) -> n = m ^ ext)) + let fname = Filename.add_extension m ext in + List.exists list ~f:(fun (n, _) -> Filename.equal n fname)) in - Module_name.of_checked_string m, (Path.relative d (m ^ ext), ty)) + let fname = Filename.add_extension m ext in + ( Module_name.of_checked_string (Filename.to_string m) + , (Path.relative_fname d fname, ty) )) ;; (* Here we are constructing the list of artifacts for various types of things @@ -1274,7 +1300,7 @@ let pkg_mlds sctx pkg = let check_mlds_no_dupes ~pkg ~mlds = match List.rev_map mlds ~f:(fun ((_path, mld_name) as mld) -> mld_name, mld) - |> Filename.Map.of_list + |> String.Map.of_list with | Ok m -> m | Error (_, (p1, _name1), (p2, _name2)) -> diff --git a/src/dune_rules/opam_create.ml b/src/dune_rules/opam_create.ml index d02b7612ccd..908ee198e8e 100644 --- a/src/dune_rules/opam_create.ml +++ b/src/dune_rules/opam_create.ml @@ -383,12 +383,12 @@ let opam_fields project (package : Package.t) = if dune_version < (1, 11) then fields else Opam_file.Create.normalise_field_order fields ;; -let template_file = Path.extend_basename ~suffix:".template" +let template_file = Path.extend_basename ~suffix:Filename.template let build_path ~build_dir pkg = let opam_path = Path.Build.append_source build_dir (Package.opam_file pkg) in match Package.has_opam_file pkg with - | Generated_with_diff -> Path.Build.extend_basename opam_path ~suffix:".generated" + | Generated_with_diff -> Path.Build.extend_basename opam_path ~suffix:Filename.generated | Exists _ | Generated -> opam_path ;; @@ -546,7 +546,8 @@ let gen_rules sctx ~dir ~nearest_src_dir ~src_dir = else ( let allowed_subdirs = match opam_file_location with - | `Inside_opam_directory when project_rules -> Filename.Set.singleton opam_dir + | `Inside_opam_directory when project_rules -> + Filename.Set.singleton Filename.opam | `Relative_to_project | `Inside_opam_directory -> Filename.Set.empty in let rules = diff --git a/src/dune_rules/pkg_rules.ml b/src/dune_rules/pkg_rules.ml index 7e9fde90067..68fca67c464 100644 --- a/src/dune_rules/pkg_rules.ml +++ b/src/dune_rules/pkg_rules.ml @@ -502,10 +502,11 @@ module Pkg = struct let contents = Fs_memo.Dir_contents.to_list contents in List.rev_filter_partition_map contents ~f:(fun (name, kind) -> (* TODO handle links and cycles correctly *) - let relative = Path.Local.relative path name in + let name_s = Filename.to_string name in + let relative = Path.Local.relative_fname path name in match kind with - | S_DIR -> if skip_dir name then Skip else Right relative - | _ -> if skip_file name then Skip else Left relative) + | S_DIR -> if skip_dir name_s then Skip else Right relative + | _ -> if skip_file name_s then Skip else Left relative) in let acc = Path.Local.Set.of_list files |> Path.Local.Set.union acc in Memo.map_reduce @@ -694,7 +695,7 @@ module Substitute = struct let hash_input_repr = Repr.T4.repr paths_repr - Repr.(list (pair String.repr Path.repr)) + Repr.(list (pair Filename.repr Path.repr)) Repr.(list (pair variable_map_repr paths_repr)) Package_version.repr ;; @@ -705,7 +706,7 @@ module Substitute = struct Digest.repr hash_input_repr ( paths expander.paths - , String.Map.to_list artifacts + , Filename.Map.to_list artifacts , Package.Name.Map.to_list_map depends ~f:(fun _ (m, p) -> m, paths p) , expander.version ) |> Digest.to_string_raw @@ -979,6 +980,7 @@ module Action_expander = struct let dune = Path.of_string Sys.executable_name in Memo.return @@ Ok dune | program -> + let program = Filename.of_string_exn program in let* artifacts = t.artifacts in (match Filename.Map.find artifacts program with | Some s -> Memo.return @@ Ok s @@ -996,7 +998,7 @@ module Action_expander = struct Error (Action.Prog.Not_found.create ?hint - ~program + ~program:(Filename.to_string program) ~context:t.context ~loc:(Some loc) ()))))) @@ -1154,7 +1156,11 @@ module Action_expander = struct let binaries = Section.Map.Multi.find cookie.files Bin |> List.fold_left ~init:binaries ~f:(fun acc bin -> - Filename.Map.set acc (Bin.strip_exe (Path.basename bin)) bin) + Filename.Map.set + acc + (Filename.of_string_exn + (Bin.strip_exe (Path.basename bin |> Filename.to_string))) + bin) in let dep_info = let variables = @@ -1216,7 +1222,7 @@ module Action_expander = struct ;; let dune_exe context = - Which.which ~path:(Env_path.path Env.initial) "dune" + Which.which ~path:(Env_path.path Env.initial) Filename.dune >>| function | Some s -> Ok s | None -> Error (Action.Prog.Not_found.create ~loc:None ~context ~program:"dune" ()) @@ -1769,6 +1775,7 @@ module Install_action = struct let package = Path.basename install_file |> Filename.remove_extension + |> Filename.to_string |> Package.Name.of_string in let roots = @@ -1785,7 +1792,7 @@ module Install_action = struct let collect_files ~root ~skip_dirs = List.iter skip_dirs ~f:(fun s -> assert (Path.equal root (Path.parent_exn s))); - let path_of ~dir fname = Path.relative root (Filename.concat dir fname) in + let path_of ~dir fname = Path.relative root (Filename.append dir fname) in Fpath.traverse ~dir:(Path.to_string root) ~init:[] @@ -1806,7 +1813,7 @@ module Install_action = struct | Some (sandbox, source) -> let ctx = let name = Path.basename sandbox in - Path.relative (Path.build Path.Build.root) name + Path.relative_fname (Path.build Path.Build.root) name in Path.append_source ctx source ;; @@ -1894,7 +1901,11 @@ module Install_action = struct to be deleted, so we don't be able to fetch the part of the file that's bad *) let open Pp.O in - let error = Pp.textf "Error parsing %s" (Path.basename config_file) in + let error = + Pp.textf + "Error parsing %s" + (Path.basename config_file |> Filename.to_string) + in match loc with | None -> error | Some loc -> @@ -1958,7 +1969,7 @@ module Install_action = struct let resolve_symlinks_in root = let on_symlink ~dir fname () = - let path = Filename.concat root (Filename.concat dir fname) in + let path = Filename.concat root (Filename.append dir fname) in match Fpath.follow_symlink path with | Error (Unix_error e) -> Unix_error.Detailed.raise e | Error Not_a_symlink -> @@ -2480,7 +2491,10 @@ let setup_rules ~components ~dir ctx = | true, ".dev-tool" :: _ :: _ :: _ -> Memo.return @@ Gen_rules.redirect_to_parent Gen_rules.Rules.empty | is_default, [] -> - let sub_dirs = ".pkg" :: (if is_default then [ ".dev-tool" ] else []) in + let sub_dirs = + Filename.pkg_dir_basename + :: (if is_default then [ Filename.dev_tool_dir_basename ] else []) + in let build_dir_only_sub_dirs = Gen_rules.Build_only_sub_dirs.singleton ~dir @@ Subdir_set.of_list sub_dirs in diff --git a/src/dune_rules/pp_spec_rules.ml b/src/dune_rules/pp_spec_rules.ml index 04eb9864105..cd1ea8acd2b 100644 --- a/src/dune_rules/pp_spec_rules.ml +++ b/src/dune_rules/pp_spec_rules.ml @@ -200,7 +200,7 @@ let lint_module sctx ~sandbox ~dir ~expander ~lint ~lib_name ~scope = add_alias ~loc (promote_correction - ~suffix:corrected_suffix + ~suffix:(Filename.of_string_exn corrected_suffix) ~ml_kind source (let* exe, flags, args = driver_and_flags in @@ -350,7 +350,7 @@ let pp_one_module ~loc ~dir (promote_correction_with_target - ~suffix:corrected_suffix + ~suffix:(Filename.of_string_exn corrected_suffix) (pp_input_path m ~ml_kind |> Path.as_in_build_dir_exn) (Action_builder.with_file_targets ~file_targets:[ dst ] diff --git a/src/dune_rules/ppx_driver.ml b/src/dune_rules/ppx_driver.ml index 8a9df588904..341ddfbbbdf 100644 --- a/src/dune_rules/ppx_driver.ml +++ b/src/dune_rules/ppx_driver.ml @@ -329,7 +329,8 @@ let build_ppx_driver = in let+ (_ : Exe.dep_graphs) = let program : Exe.Program.t = - { name = Filename.remove_extension (Path.Build.basename target) + { name = + Path.Build.basename target |> Filename.remove_extension |> Filename.to_string ; main_module_name ; loc = Loc.none } diff --git a/src/dune_rules/rocq/rocq_config.ml b/src/dune_rules/rocq/rocq_config.ml index fd5877aa416..438d1d60fb2 100644 --- a/src/dune_rules/rocq/rocq_config.ml +++ b/src/dune_rules/rocq/rocq_config.ml @@ -261,7 +261,12 @@ let expand source macro ~dir artifacts_host = let s = Pform.Macro_invocation.Args.whole macro in let open Memo.O in let* rocq = - Artifacts.binary artifacts_host ~where:Original_path ~dir ~loc:None "rocq" + Artifacts.binary + artifacts_host + ~where:Original_path + ~dir + ~loc:None + (Filename.to_string Filename.rocq) in let expand m k s = let+ t = m ~rocq in diff --git a/src/dune_rules/rocq/rocq_path.ml b/src/dune_rules/rocq/rocq_path.ml index ce019bebd1a..9a42dc17893 100644 --- a/src/dune_rules/rocq/rocq_path.ml +++ b/src/dune_rules/rocq/rocq_path.ml @@ -51,6 +51,7 @@ let build_user_contrib ~vo ~path ~name = { name; path; vo; corelib = false } (* Scanning todos: blacklist? *) let scan_vo ~dir dir_contents = let f (d, kind) = + let d = Filename.to_string d in match kind with (* Skip some files as Rocq does, for now files with '-' *) | _ when String.contains d '-' -> None @@ -84,6 +85,7 @@ let rec scan_path ~(f : ('prefix, 'res) Scan_action.t) ~acc ~prefix ~dir dir_con = let open Memo.O in let f (d, kind) = + let d = Filename.to_string d in match kind with (* We skip directories starting by . , this is mainly to avoid .coq-native *) @@ -186,7 +188,7 @@ let of_rocq_install rocq = let of_rocq_install context = let open Memo.O in - let* rocq = Context.which context "rocq" in + let* rocq = Context.which context Filename.rocq in match rocq with | None -> Memo.return [] | Some rocq -> of_rocq_install rocq diff --git a/src/dune_rules/rocq/rocq_sources.ml b/src/dune_rules/rocq/rocq_sources.ml index 995ae80de0c..f1c45a1245f 100644 --- a/src/dune_rules/rocq/rocq_sources.ml +++ b/src/dune_rules/rocq/rocq_sources.ml @@ -47,14 +47,15 @@ let rocq_modules_of_files ~dirs = let build_mod_dir (sd : Source_file_dir.t) = let prefix = sd.path_to_root in let v_files = - Filename.Array.Set.filter sd.files ~f:(fun f -> String.ends_with ~suffix:".v" f) + Filename.Array.Set.filter sd.files ~f:(fun f -> + String.ends_with ~suffix:".v" (Filename.to_string f)) in Filename.Array.Set.to_list_map v_files ~f:(fun file -> let name, _ = Filename.split_extension file in - let name = Rocq_module.Name.make name in + let name = Rocq_module.Name.make (Filename.to_string name) in Rocq_module.make - ~source:(Path.build @@ Path.Build.relative sd.dir file) - ~prefix + ~source:(Path.build @@ Path.Build.relative_fname sd.dir file) + ~prefix:(Filename.L.to_string prefix) ~name) in List.concat_map ~f:build_mod_dir (Nonempty_list.to_list dirs) @@ -63,14 +64,15 @@ let rocq_modules_of_files ~dirs = let expected_files_of_dirs ~dirs = let build_expected (sd : Source_file_dir.t) = let v_files = - Filename.Array.Set.filter sd.files ~f:(fun f -> String.ends_with ~suffix:".v" f) + Filename.Array.Set.filter sd.files ~f:(fun f -> + String.ends_with ~suffix:".v" (Filename.to_string f)) in Filename.Array.Set.to_list_map v_files ~f:(fun file -> let name, _ = Filename.split_extension file in - let expected_name = name ^ ".expected" in - let source = Path.Build.relative sd.dir file in + let expected_name = Filename.add_extension name Filename.Extension.expected in + let source = Path.Build.relative_fname sd.dir file in if Filename.Array.Set.mem sd.files expected_name - then Some (source, Path.Build.relative sd.dir expected_name) + then Some (source, Path.Build.relative_fname sd.dir expected_name) else None) |> List.filter_opt in diff --git a/src/dune_rules/run_with_path.ml b/src/dune_rules/run_with_path.ml index 54898bf35a5..761c3327d78 100644 --- a/src/dune_rules/run_with_path.ml +++ b/src/dune_rules/run_with_path.ml @@ -128,7 +128,9 @@ module Windows_executables = struct User_error.raise ?loc ~compound - [ Pp.textf "Dune could not parse the shebang line in %s:" prog_name + [ Pp.textf + "Dune could not parse the shebang line in %s:" + (Filename.to_string prog_name) ; Pp.textf " #!%s" line ; Pp.textf "Dune currently only supports the following forms of shebang lines:" @@ -150,7 +152,7 @@ module Windows_executables = struct User_error.raise ?loc ~compound - [ Pp.textf "%s: No such file or directory" prog_name ] + [ Pp.textf "%s: No such file or directory" (Filename.to_string prog_name) ] | Some cmd -> let prog_str = Path.reach_for_running ?from:dir prog in let args = List.concat [ extra_args; prog_str :: args ] in diff --git a/src/dune_rules/simple_rules.ml b/src/dune_rules/simple_rules.ml index 70b8d49b51d..cdc89c9a8b3 100644 --- a/src/dune_rules/simple_rules.ml +++ b/src/dune_rules/simple_rules.ml @@ -247,7 +247,7 @@ let copy_files sctx ~dir ~expander ~src_dir (def : Copy_files.t) = (Path.to_string_maybe_quoted glob_in_src) (Path.Source.to_string_maybe_quoted src_dir)); let src_in_src = Path.parent_exn glob_in_src in - let glob = Path.basename glob_in_src |> Glob.of_string_exn loc in + let glob = Path.basename glob_in_src |> Filename.to_string |> Glob.of_string_exn loc in let src_in_build = match Path.as_in_source_tree src_in_src with | None -> src_in_src @@ -298,6 +298,7 @@ let copy_files sctx ~dir ~expander ~src_dir (def : Copy_files.t) = Filename_set.filenames files |> Filename.Array.Set.to_list |> Memo.parallel_iter ~f:(fun basename -> + let basename = Filename.to_string basename in let file_src = Path.relative src_in_build basename in let file_dst = Path.Build.relative dir basename in let context = Super_context.context sctx in @@ -314,7 +315,7 @@ let copy_files sctx ~dir ~expander ~src_dir (def : Copy_files.t) = in let targets = Filename.Array.Set.to_list_map (Filename_set.filenames files) ~f:(fun basename -> - let file_dst = Path.Build.relative dir basename in + let file_dst = Path.Build.relative_fname dir basename in Path.build file_dst) |> Path.Set.of_list in diff --git a/src/dune_rules/sites/plugin_rules.ml b/src/dune_rules/sites/plugin_rules.ml index bbeaca0bc96..5307929c2b6 100644 --- a/src/dune_rules/sites/plugin_rules.ml +++ b/src/dune_rules/sites/plugin_rules.ml @@ -9,7 +9,7 @@ let meta_file ~dir { name; libraries = _; site = _, (pkg, site); _ } = ; Package.Name.to_string pkg ; Site.to_string site ; Package.Name.to_string name - ; Dune_findlib.Package.meta_fn + ; Dune_findlib.Package.meta_fn |> Filename.to_string ] ;; @@ -55,7 +55,11 @@ let install_rules ~sctx ~package_db ~dir ({ name; site = loc, (pkg, site); _ } a let meta = meta_file ~dir t in let+ entry = Install_entry_with_site.make_with_site - ~dst:(sprintf "%s/%s" (Package.Name.to_string name) Dune_findlib.Package.meta_fn) + ~dst: + (sprintf + "%s/%s" + (Package.Name.to_string name) + (Dune_findlib.Package.meta_fn |> Filename.to_string)) (Site { pkg; site; loc }) (Package_db.section_of_site package_db) ~kind:File diff --git a/src/dune_rules/source_deps.ml b/src/dune_rules/source_deps.ml index 48db0b91638..e73111591a6 100644 --- a/src/dune_rules/source_deps.ml +++ b/src/dune_rules/source_deps.ml @@ -27,7 +27,7 @@ let files_with_filter dir ~filter = let files = Source_tree.Dir.filenames dir |> Filename.Array.Set.to_list - |> Path.Set.of_list_map ~f:(fun fn -> Path.relative path fn) + |> Path.Set.of_list_map ~f:(fun fn -> Path.relative_fname path fn) |> Path.Set.filter ~f:filter in let empty_directories = diff --git a/src/dune_rules/stanzas/library.ml b/src/dune_rules/stanzas/library.ml index 48404d80d5c..99e25dc6343 100644 --- a/src/dune_rules/stanzas/library.ml +++ b/src/dune_rules/stanzas/library.ml @@ -554,10 +554,12 @@ let to_lib_info match pform with | Var Context_name -> let context, _ = Path.Build.extract_build_context_exn dir in - Memo.return context + Memo.return (Filename.to_string context) | Var Profile -> let context, _ = Path.Build.extract_build_context_exn dir in - let+ profile = Per_context.profile (Context_name.of_string context) in + let+ profile = + Per_context.profile (Context_name.of_string (Filename.to_string context)) + in Profile.to_string profile | _ -> Memo.return @@ Lib_config.get_for_enabled_if lib_config pform in diff --git a/src/dune_rules/test_rules.ml b/src/dune_rules/test_rules.ml index 3b8300d2a2d..7da8057657a 100644 --- a/src/dune_rules/test_rules.ml +++ b/src/dune_rules/test_rules.ml @@ -12,7 +12,8 @@ let test_kind ~dir dir_contents name ext = (* let dir = Dir_contents.dir dir_contents in *) let files = Dir_contents.text_files dir_contents in let expected_basename = name ^ ".expected" in - if Filename.Array.Set.mem files expected_basename + let expected_basename_fn = Filename.of_string_exn expected_basename in + if Filename.Array.Set.mem files expected_basename_fn then `Expect { Diff.file1 = Path.build (Path.Build.relative dir expected_basename) diff --git a/src/dune_rules/top_module.ml b/src/dune_rules/top_module.ml index 2712e6f504f..a09e28dc479 100644 --- a/src/dune_rules/top_module.ml +++ b/src/dune_rules/top_module.ml @@ -24,7 +24,7 @@ let find_module sctx src = let* name = let fname = Path.Build.basename src in let name = Filename.remove_extension fname in - if String.equal fname name then None else Some name + if Filename.equal fname name then None else Some (Filename.to_string name) in Module_name.of_string_opt name with @@ -90,7 +90,7 @@ let gen_rules sctx ~dir:rules_dir ~comps = >>| List.filter_map ~f:(Obj_dir.Module.cm_file obj_dir ~kind:(Ocaml Cmi))) >>= Memo.parallel_iter ~f:(fun file -> (let src = Path.build file in - let dst = Path.Build.relative rules_dir (Path.Build.basename file) in + let dst = Path.Build.relative_fname rules_dir (Path.Build.basename file) in Action_builder.symlink ~src ~dst) |> Super_context.add_rule sctx ~dir:rules_dir) in diff --git a/src/dune_rules/toplevel.ml b/src/dune_rules/toplevel.ml index 33fda8c18a4..9d87b090978 100644 --- a/src/dune_rules/toplevel.ml +++ b/src/dune_rules/toplevel.ml @@ -256,7 +256,7 @@ module Stanza = struct let resolved = make ~cctx ~source ~preprocess:toplevel.pps expander in setup_rules_and_return_exe_path resolved ~linkage in - let symlink = Path.Build.relative dir (Path.Build.basename exe) in + let symlink = Path.Build.relative_fname dir (Path.Build.basename exe) in Super_context.add_rule sctx ~dir diff --git a/src/dune_rules/utop.ml b/src/dune_rules/utop.ml index 74251f295be..0ea31cbccc1 100644 --- a/src/dune_rules/utop.ml +++ b/src/dune_rules/utop.ml @@ -2,7 +2,7 @@ open Import open Memo.O let exe_name = "utop" -let utop_dir_basename = ".utop" +let utop_dir_basename = Filename.utop_dir_basename let utop_exe = (* Use the [.exe] version. As the utop executable is declared with [(modes @@ -10,13 +10,13 @@ let utop_exe = that so that it works without hassle when generating a utop for a library with C stubs. *) Filename.concat - utop_dir_basename + (Filename.to_string utop_dir_basename) (exe_name ^ Filename.Extension.to_string (Mode.exe_ext Mode.Byte)) ;; let source ~dir = Toplevel.Source.make - ~dir:(Path.Build.relative dir utop_dir_basename) + ~dir:(Path.Build.relative_fname dir utop_dir_basename) ~loc:(Loc.in_dir (Path.build dir)) ~main:"UTop_main.main ();" ~name:exe_name @@ -156,7 +156,9 @@ let utop_dev_tool_lock_dir_exists = Fs_memo.dir_exists (Path.Outside_build_dir.External path)) ;; -let utop_findlib_conf = Filename.concat utop_dir_basename "findlib.conf" +let utop_findlib_conf = + Filename.append (Filename.to_string utop_dir_basename) Filename.findlib_conf +;; (* The lib directory of the utop package and of each of its dependencies within the _build directory (or the toolchains directory in the case of the OCaml diff --git a/src/dune_rules/utop.mli b/src/dune_rules/utop.mli index 9c9a2ad8b3f..d54a3543ed3 100644 --- a/src/dune_rules/utop.mli +++ b/src/dune_rules/utop.mli @@ -2,12 +2,16 @@ open Import -(** Return the name of the utop target inside a directory where some libraries - are defined. *) -val utop_exe : Filename.t +(** Path of the utop executable target relative to the directory where utop + rules are generated. *) +val utop_exe : string val utop_dir_basename : Filename.t -val utop_findlib_conf : Filename.t + +(** Path of the generated findlib configuration file relative to the directory + where utop rules are generated. *) +val utop_findlib_conf : string + val utop_dev_tool_lock_dir_exists : bool Memo.Lazy.t val libs_under_dir : Super_context.t -> db:Lib.DB.t -> dir:Path.t -> Lib.t list Memo.t val setup : Super_context.t -> dir:Path.Build.t -> unit Memo.t diff --git a/src/dune_rules/which.ml b/src/dune_rules/which.ml index 4b186c4f734..5de243c2fcf 100644 --- a/src/dune_rules/which.ml +++ b/src/dune_rules/which.ml @@ -8,16 +8,17 @@ let programs_for_which_we_prefer_opt_ext = let with_opt p = p ^ ".opt" let candidates prog = - let base = [ Bin.add_exe prog ] in + let prog = Filename.to_string prog in + let base = [ Filename.of_string_exn (Bin.add_exe prog) ] in if List.mem programs_for_which_we_prefer_opt_ext prog ~equal:String.equal - then Bin.add_exe (with_opt prog) :: base + then Filename.of_string_exn (Bin.add_exe (with_opt prog)) :: base else base ;; let best_in_dir ~dir program = candidates program |> Memo.List.find_map ~f:(fun fn -> - let path = Path.relative dir fn in + let path = Path.relative_fname dir fn in Fs_memo.file_exists (Path.as_outside_build_dir_exn path) >>| function | false -> None @@ -25,7 +26,7 @@ let best_in_dir ~dir program = ;; module rec Rec : sig - val which : path:Path.t list -> string -> Path.t option Memo.t + val which : path:Path.t list -> Filename.t -> Path.t option Memo.t end = struct open Rec @@ -42,10 +43,10 @@ end = struct let which = let memo = let module Input = struct - type t = Path.t list * string + type t = Path.t list * Filename.t - let equal = Tuple.T2.equal (List.equal Path.equal) String.equal - let hash = Tuple.T2.hash (List.hash Path.hash) String.hash + let equal = Tuple.T2.equal (List.equal Path.equal) Filename.equal + let hash = Tuple.T2.hash (List.hash Path.hash) Filename.hash let to_dyn = Dyn.opaque end in diff --git a/src/dune_targets/dune_targets.ml b/src/dune_targets/dune_targets.ml index 5d69c845a93..7088d94298f 100644 --- a/src/dune_targets/dune_targets.ml +++ b/src/dune_targets/dune_targets.ml @@ -64,15 +64,17 @@ module Validated = struct } let iter { root; files; dirs } ~file ~dir = - Filename.Set.iter files ~f:(fun fn -> file (Path.Build.relative root fn)); - Filename.Set.iter dirs ~f:(fun dn -> dir (Path.Build.relative root dn)) + Filename.Set.iter files ~f:(fun fn -> file (Path.Build.relative_fname root fn)); + Filename.Set.iter dirs ~f:(fun dn -> dir (Path.Build.relative_fname root dn)) ;; let fold { root; files; dirs } ~init ~file ~dir = let acc = - Filename.Set.fold files ~init ~f:(fun fn -> file (Path.Build.relative root fn)) + Filename.Set.fold files ~init ~f:(fun fn -> + file (Path.Build.relative_fname root fn)) in - Filename.Set.fold dirs ~init:acc ~f:(fun dn -> dir (Path.Build.relative root dn)) + Filename.Set.fold dirs ~init:acc ~f:(fun dn -> + dir (Path.Build.relative_fname root dn)) ;; let head { root; files; dirs } = @@ -84,7 +86,7 @@ module Validated = struct | Some name -> name | None -> assert false) in - Path.Build.relative root name + Path.Build.relative_fname root name ;; let unvalidate t : unvalidated = @@ -120,7 +122,7 @@ let validate { files; dirs } = if Filename.Set.mem t.files name then Validation_result.File_and_directory_target_with_the_same_name - (Path.Build.relative t.root name) + (Path.Build.relative_fname t.root name) else Valid { t with dirs = Filename.Set.add t.dirs name } in let build (init : Validation_result.t) ~paths ~f = @@ -162,11 +164,12 @@ module Produced = struct } let head { root; contents = { files; subdirs } } = - Path.Build.relative - root - (match Filename.Map.choose files with - | Some (x, _) -> x - | None -> Filename.Map.choose subdirs |> Option.value_exn |> fst) + let basename = + match Filename.Map.choose files with + | Some (x, _) -> x + | None -> Filename.Map.choose subdirs |> Option.value_exn |> fst + in + Path.Build.relative_fname root basename ;; let equal @@ -253,7 +256,7 @@ module Produced = struct let parent = Path.Local.parent_exn file in if Path.Local.is_root parent then ( - let file = Path.Local.to_string file in + let file = Path.Local.basename file in match mb_payload with | Some payload -> { contents with files = Filename.Map.add_exn contents.files file payload } @@ -273,15 +276,15 @@ module Produced = struct match file_f (let dir_build = Path.Build.relative root dir in - Path.Local.relative (Path.Build.local dir_build) fname) + Path.Local.relative_fname (Path.Build.local dir_build) fname) with | None -> acc | Some payload -> - let key = Path.Local.of_string (Filename.concat dir fname) in + let key = Path.Local.of_string (Filename.append dir fname) in Path.Local.Map.set acc key (Some payload) in let on_dir ~dir fname acc = - let key = Path.Local.of_string (Filename.concat dir fname) in + let key = Path.Local.of_string (Filename.append dir fname) in Path.Local.Map.set acc key None in let on_error ~dir err _acc = @@ -302,7 +305,7 @@ module Produced = struct ~on_other: (`Call (fun ~dir fname kind _ -> - let path = Path.Build.relative root (Filename.concat dir fname) in + let path = Path.Build.relative root (Filename.append dir fname) in raise_notrace (Traverse_error (Unsupported_file (path, kind))))) ~on_symlink:(`Call (fun ~dir fname acc -> on_file ~dir fname acc, None)) ~on_error:(`Call on_error) @@ -317,7 +320,7 @@ module Produced = struct let open Result.O in (* We assume here that [dir_name] is either a child of [root], or that we're ok with having [root/a/b] but not [root/a]. *) let aggregate_dir { root; contents } dir_name = - let dir = Path.Build.relative root dir_name in + let dir = Path.Build.relative_fname root dir_name in let* new_contents = contents_of_dir ~file_f:(fun _ -> Some ()) dir in if is_empty_dir_conts new_contents then Error (Empty_dir dir) @@ -355,7 +358,7 @@ module Produced = struct let+ contents = Filename.Map.find subdirs final in Right contents) | parent :: rest -> - let path = Path.Local.relative path parent in + let path = Path.Local.relative_fname path parent in let* subdir = Filename.Map.find subdirs parent in aux path subdir rest in @@ -394,11 +397,11 @@ module Produced = struct Seq.append (Filename.Map.to_seq files |> Seq.map ~f:(fun (file_name, payload) -> - Path.Local.relative path file_name, payload)) + Path.Local.relative_fname path file_name, payload)) (Seq.concat (Filename.Map.to_seq subdirs |> Seq.map ~f:(fun (dir_name, subdir_contents) -> - aux (Path.Local.relative path dir_name) subdir_contents))) + aux (Path.Local.relative_fname path dir_name) subdir_contents))) in aux Path.Local.root contents ;; @@ -408,7 +411,7 @@ module Produced = struct Seq.concat (Filename.Map.to_seq subdirs |> Seq.map ~f:(fun (dir_name, dir_contents) -> - let dir = Path.Local.relative path dir_name in + let dir = Path.Local.relative_fname path dir_name in Seq.cons dir (aux dir dir_contents))) in aux Path.Local.root contents @@ -427,11 +430,11 @@ module Produced = struct let rec aux path { files; subdirs } acc = let acc' = Filename.Map.foldi files ~init:acc ~f:(fun file_name payload acc -> - let file = Path.Local.relative path file_name in + let file = Path.Local.relative_fname path file_name in f file (Some payload) acc) in Filename.Map.foldi subdirs ~init:acc' ~f:(fun dir_name dir_contents acc -> - let dir = Path.Local.relative path dir_name in + let dir = Path.Local.relative_fname path dir_name in let acc' = f dir None acc in aux dir dir_contents acc') in @@ -441,10 +444,10 @@ module Produced = struct let iteri_dir_contents contents ~f ~d = let rec aux path { files; subdirs } = Filename.Map.iteri files ~f:(fun file_name payload -> - let file = Path.Local.relative path file_name in + let file = Path.Local.relative_fname path file_name in f file payload); Filename.Map.iteri subdirs ~f:(fun dir_name dir_contents -> - let dir = Path.Local.relative path dir_name in + let dir = Path.Local.relative_fname path dir_name in d dir; aux dir dir_contents) in @@ -457,11 +460,11 @@ module Produced = struct let rec aux path { files; subdirs } = let file_list = Filename.Map.to_list_map files ~f:(fun file_name payload -> - f (Path.Local.relative path file_name) (Some payload)) + f (Path.Local.relative_fname path file_name) (Some payload)) in let dir_list = Filename.Map.to_list_map subdirs ~f:(fun dir_name dir_contents -> - let dir = Path.Local.relative path dir_name in + let dir = Path.Local.relative_fname path dir_name in let d = f dir None in d :: aux dir dir_contents) |> List.concat @@ -477,7 +480,7 @@ module Produced = struct let iter_dirs { contents; root = _ } ~f = let rec aux path { subdirs; files = _ } = Filename.Map.iteri subdirs ~f:(fun dir_name dir_contents -> - let dir = Path.Local.relative path dir_name in + let dir = Path.Local.relative_fname path dir_name in f dir; aux dir dir_contents) in @@ -485,7 +488,7 @@ module Produced = struct ;; module Path_traversal = Fiber.Make_parallel_map (Path.Local.Map) - module Filename_traversal = Fiber.Make_parallel_map (String.Map) + module Filename_traversal = Fiber.Make_parallel_map (Filename.Map) let parallel_map { root; contents } ~f = let open Fiber.O in @@ -494,11 +497,11 @@ module Produced = struct Fiber.fork_and_join (fun () -> Filename_traversal.parallel_map files ~f:(fun file_name -> - let file = Path.Local.relative path file_name in + let file = Path.Local.relative_fname path file_name in f file)) (fun () -> Filename_traversal.parallel_map subdirs ~f:(fun dir_name -> - let dir = Path.Local.relative path dir_name in + let dir = Path.Local.relative_fname path dir_name in aux dir)) in { files; subdirs } @@ -541,7 +544,7 @@ module Produced = struct ~init:(Fiber.return Filename.Map.empty) ~f:(fun file_name _payload acc -> let* acc = acc in - let path = Path.Build.relative path file_name in + let path = Path.Build.relative_fname path file_name in let* result = f path in match result with | None -> Fiber.return acc @@ -553,7 +556,7 @@ module Produced = struct ~init:(Fiber.return Filename.Map.empty) ~f:(fun dir_name dir_contents acc -> let* acc = acc in - let dir = Path.Build.relative path dir_name in + let dir = Path.Build.relative_fname path dir_name in let* mapped = aux dir dir_contents in Fiber.return (Filename.Map.set acc dir_name mapped)) and aux path { files; subdirs } = @@ -594,11 +597,11 @@ module Produced = struct let rec aux path { files; subdirs } = let files = Filename.Map.filter_mapi files ~f:(fun file _ -> - f (Path.Build.relative path file)) + f (Path.Build.relative_fname path file)) in let subdirs = Filename.Map.mapi subdirs ~f:(fun dir subdirs_contents -> - let dir = Path.Build.relative path dir in + let dir = Path.Build.relative_fname path dir in aux dir subdirs_contents) in (match d with diff --git a/src/dune_trace/event.ml b/src/dune_trace/event.ml index a684d3085b6..0f00d9d2e8b 100644 --- a/src/dune_trace/event.ml +++ b/src/dune_trace/event.ml @@ -334,7 +334,7 @@ let args_of_targets = [ ( name , Arg.list (Filename.Set.to_list_map set ~f:(fun x -> - Arg.build_path (Path.Build.relative root x))) ) + Arg.build_path (Path.Build.relative_fname root x))) ) ] in fun { root; files; dirs } -> diff --git a/src/dune_util/report_error.ml b/src/dune_util/report_error.ml index 43838a47431..0a8212f16b0 100644 --- a/src/dune_util/report_error.ml +++ b/src/dune_util/report_error.ml @@ -69,7 +69,7 @@ let get_error_from_exn = function let path = Path.of_string path |> Path.drop_optional_sandbox_root in (match Path.extract_build_context path with | None -> msg - | Some (ctxt, _) -> { msg with context = Some ctxt }) + | Some (ctxt, _) -> { msg with context = Some (Filename.to_string ctxt) }) in { responsible = User; msg; has_embedded_location; needs_stack_trace } | Code_error.E e -> diff --git a/src/dune_vcs/vcs.ml b/src/dune_vcs/vcs.ml index c9c82b031a5..baa0b5bd231 100644 --- a/src/dune_vcs/vcs.ml +++ b/src/dune_vcs/vcs.ml @@ -7,7 +7,8 @@ module Kind = struct | Git | Hg - let of_dir_name = function + let of_dir_name name = + match Filename.to_string name with | ".git" -> Some Git | ".hg" -> Some Hg | _ -> None @@ -19,9 +20,9 @@ module Kind = struct then of_dir_name name else None in - match kind ".git" with + match kind Filename.git_dir_basename with | Some _ as kind -> kind - | None -> kind ".hg" + | None -> kind Filename.hg_dir_basename ;; let to_dyn t = diff --git a/src/install/context.ml b/src/install/context.ml index 50afaaca1d8..72c79407db3 100644 --- a/src/install/context.ml +++ b/src/install/context.ml @@ -22,7 +22,7 @@ let of_path path = | Build (Regular (With_context (name, src))) -> Some (if Context_name.equal name install_context.name - then Context_name.of_string (Path.Source.basename src) + then Context_name.of_string (Path.Source.basename src |> Filename.to_string) else name) | Build (Anonymous_action (With_context (name, _))) -> Some name | _ -> None @@ -39,5 +39,6 @@ let analyze_path ctx_name source = | true -> (match Path.Source.split_first_component source with | None -> Invalid - | Some (ctx, path) -> Install (Context_name.of_string ctx, Path.Source.of_local path)) + | Some (ctx, path) -> + Install (Context_name.of_string (Filename.to_string ctx), Path.Source.of_local path)) ;; diff --git a/src/install/entry.ml b/src/install/entry.ml index c8139c3a984..444b7540bde 100644 --- a/src/install/entry.ml +++ b/src/install/entry.ml @@ -85,7 +85,9 @@ type ('src, 'kind) t = } let has_extension filename ext = - let extension = Filename.extension filename in + let extension = + Stdlib.Filename.extension filename |> Filename.Extension.Or_empty.of_string_exn + in Filename.Extension.Or_empty.check extension ext ;; @@ -218,7 +220,11 @@ module Expanded = struct let of_install_file ~optional ~src ~dst ~section = { src ; section - ; dst = Dst.of_install_file ~section ~src_basename:(Path.basename src) dst + ; dst = + Dst.of_install_file + ~section + ~src_basename:(Path.basename src |> Filename.to_string) + dst ; kind = File ; optional } @@ -238,7 +244,10 @@ module Expanded = struct |> List.iter ~f:(fun (e : Path.t t) -> let src = Path.to_string e.src in match - Dst.to_install_file ~src_basename:(Path.basename e.src) ~section:e.section e.dst + Dst.to_install_file + ~src_basename:(Path.basename e.src |> Filename.to_string) + ~section:e.section + e.dst with | None -> pr " %S" src | Some dst -> pr " %S {%S}" src dst); diff --git a/src/scheme/scheme.ml b/src/scheme/scheme.ml index 8853a7de424..98aa2624435 100644 --- a/src/scheme/scheme.ml +++ b/src/scheme/scheme.ml @@ -20,24 +20,24 @@ module Evaluated : sig val empty : unit -> 'a t val restrict : Path.Build.w Dir_set.t -> 'a t Memo.Lazy.t -> 'a t Memo.t val finite : union_rules:('a -> 'a -> 'a) -> 'a Path.Build.Map.t -> 'a t - val get_rules : 'a t -> dir:Path.Build.t -> ('a option * String.Set.t) Memo.t + val get_rules : 'a t -> dir:Path.Build.t -> ('a option * Filename.Set.t) Memo.t end = struct type 'rules t = - { by_child : 'rules t Memo.Lazy.t String.Map.t + { by_child : 'rules t Memo.Lazy.t Filename.Map.t ; rules_here : 'rules option Memo.Lazy.t } - let empty () = { by_child = String.Map.empty; rules_here = Memo.Lazy.of_val None } + let empty () = { by_child = Filename.Map.empty; rules_here = Memo.Lazy.of_val None } let descend t dir = - match String.Map.find t.by_child dir with + match Filename.Map.find t.by_child dir with | None -> Memo.return (empty ()) | Some res -> Memo.Lazy.force res ;; let rec union ~union_rules x y = { by_child = - String.Map.union x.by_child y.by_child ~f:(fun _key data1 data2 -> + Filename.Map.union x.by_child y.by_child ~f:(fun _key data1 data2 -> Some (Memo.Lazy.create ~name:"scheme-union" (fun () -> let+ x = Memo.Lazy.force data1 @@ -67,12 +67,12 @@ end = struct user is interested in is not actually in the set. We're not fully committed to supporting this case though, anyway. *) let+ t = Memo.Lazy.force t in - String.Map.mapi t.by_child ~f:(fun dir v -> + Filename.Map.mapi t.by_child ~f:(fun dir v -> Memo.lazy_ ~name:"restrict-by-child-default" (fun () -> restrict (Dir_set.descend dirs dir) v)) | false -> Dir_set.exceptions dirs - |> String.Map.mapi ~f:(fun dir v -> + |> Filename.Map.mapi ~f:(fun dir v -> Memo.lazy_ ~name:"restrict-by-child-non-default-outer" (fun () -> restrict v @@ -88,9 +88,10 @@ end = struct let singleton = let rec go rules = function - | [] -> { by_child = String.Map.empty; rules_here = Memo.Lazy.of_val (Some rules) } + | [] -> + { by_child = Filename.Map.empty; rules_here = Memo.Lazy.of_val (Some rules) } | x :: xs -> - { by_child = String.Map.singleton x (Memo.Lazy.of_val (go rules xs)) + { by_child = Filename.Map.singleton x (Memo.Lazy.of_val (go rules xs)) ; rules_here = Memo.Lazy.of_val None } in @@ -111,7 +112,7 @@ end = struct fun t ~dir -> let* t = loop (Path.Build.explode dir) t in let+ rules = Memo.Lazy.force t.rules_here in - rules, String.Set.of_keys t.by_child + rules, Filename.Set.of_keys t.by_child ;; end diff --git a/src/source/cram_test.ml b/src/source/cram_test.ml index bec1fe2cad3..ab58c669101 100644 --- a/src/source/cram_test.ml +++ b/src/source/cram_test.ml @@ -7,9 +7,9 @@ type t = ; dir : Path.Source.t } -let fname_in_dir_test = "run.t" +let fname_in_dir_test = Filename.run_t let suffix = ".t" -let is_cram_suffix = String.ends_with ~suffix +let is_cram_suffix fn = String.ends_with (Filename.to_string fn) ~suffix let to_dyn = let open Dyn in @@ -27,7 +27,11 @@ let path = function ;; let name t = - path t |> Path.Source.basename |> String.drop_suffix ~suffix |> Option.value_exn + path t + |> Path.Source.basename + |> Filename.to_string + |> String.drop_suffix ~suffix + |> Option.value_exn ;; let script t = diff --git a/src/source/dir_contents.ml b/src/source/dir_contents.ml index b526bca9d5a..32d6459317b 100644 --- a/src/source/dir_contents.ml +++ b/src/source/dir_contents.ml @@ -48,11 +48,12 @@ let empty = { files = Filename.Array.Set.empty; dirs = Filename.Array.Map.empty let to_dyn { files; dirs } = let open Dyn in record - [ "files", Set (Filename.Array.Set.to_list_map files ~f:Dyn.string) + [ "files", Set (Filename.Array.Set.to_list_map files ~f:Filename.to_dyn) ; ( "dirs" , list (pair string File.to_dyn) - (Filename.Array.Map.to_list_map dirs ~f:(fun name file -> name, file)) ) + (Filename.Array.Map.to_list_map dirs ~f:(fun name file -> + Filename.to_string name, file)) ) ] ;; @@ -65,6 +66,7 @@ let is_special (st_kind : Unix.file_kind) = ;; let is_temp_file fn = + let fn = Filename.to_string fn in String.starts_with ~prefix:".#" fn || String.ends_with ~suffix:".swp" fn || String.ends_with ~suffix:"~" fn @@ -79,7 +81,7 @@ let of_source_path_impl path = "Unable to read directory %s. Ignoring." (Path.Source.to_string_maybe_quoted path) ; Pp.text "Remove this message by ignoring by adding:" - ; Pp.textf "(dirs \\ %s)" (Path.Source.basename path) + ; Pp.textf "(dirs \\ %s)" (Path.Source.basename path |> Filename.to_string) ; Pp.textf "to the dune file: %s" (Path.Source.to_string_maybe_quoted @@ -91,7 +93,7 @@ let of_source_path_impl path = let+ files, dirs = Fs_memo.Dir_contents.to_list dir_contents |> Memo.parallel_map ~f:(fun (fn, (kind : File_kind.t)) -> - let path = Path.Source.relative path fn in + let path = Path.Source.relative_fname path fn in if is_special kind || Path.Source.is_in_build_dir path || is_temp_file fn then Memo.return List.Skip else diff --git a/src/source/dune_file.ml b/src/source/dune_file.ml index a5614ee59a4..9c6b97aeda6 100644 --- a/src/source/dune_file.ml +++ b/src/source/dune_file.ml @@ -27,8 +27,8 @@ open Memo.O are somewhat mixed together. *) -let fname = "dune" -let alternative_fname = "dune-file" +let fname = Filename.dune +let alternative_fname = Filename.dune_file type kind = | Plain @@ -67,7 +67,10 @@ module Dir_map = struct | None -> files | Some (_, glob) -> Filename.Array.Set.filter files ~f:(fun filename -> - Predicate_lang.Glob.test glob ~standard:Predicate_lang.true_ filename) + Predicate_lang.Glob.test + glob + ~standard:Predicate_lang.true_ + (Filename.to_string filename)) ;; end @@ -560,7 +563,7 @@ let ensure_dune_project_file_exists = let project_dir = Dune_project.root project in let+ exists = let supposed_project_file = - Path.Source.relative project_dir Dune_project.filename + Path.Source.relative_fname project_dir Dune_project.filename in Path.Outside_build_dir.In_source_dir supposed_project_file |> Fs_memo.file_exists in @@ -616,6 +619,6 @@ let load ~dir (status : Source_dir_status.t) project ~files ~parent = | None -> Memo.return () | Some _ -> ensure_dune_project_file_exists project in - let file = Option.map file ~f:(Path.Source.relative dir) in + let file = Option.map file ~f:(fun file -> Path.Source.relative_fname dir file) in load file ~from_parent:parent ~project >>| Option.some ;; diff --git a/src/source/include_stanza.ml b/src/source/include_stanza.ml index d4e693c0ded..ef3452f1fce 100644 --- a/src/source/include_stanza.ml +++ b/src/source/include_stanza.ml @@ -6,7 +6,7 @@ module type Path = sig val parent_exn : t -> t val to_string_maybe_quoted : t -> string - val relative : t -> Loc.t -> Filename.t -> t + val relative : t -> Loc.t -> string -> t val equal : t -> t -> bool val file_exists : t -> bool Memo.t val with_lexbuf_from_file : t -> f:(Lexing.lexbuf -> 'a) -> 'a Memo.t diff --git a/src/source/source_dir_status.ml b/src/source/source_dir_status.ml index f5082a06444..59749503ea6 100644 --- a/src/source/source_dir_status.ml +++ b/src/source/source_dir_status.ml @@ -118,7 +118,7 @@ module Spec = struct Predicate_lang.Glob.test pred ~standard) in Filename.Array.Set.fold dirs ~init:Filename.Map.empty ~f:(fun dir acc -> - match Map.map f ~f:(fun pred -> pred dir) |> Set.to_list with + match Map.map f ~f:(fun pred -> pred (Filename.to_string dir)) |> Set.to_list with | [] -> acc | statuses -> (* If a directory has a status other than [Normal], then the [Normal] @@ -136,7 +136,7 @@ module Spec = struct User_error.raise [ Pp.textf "Directory %s was marked as %s, it can't be marked as %s." - dir + (Filename.to_string dir) (String.enumerate_and (List.map statuses ~f:to_string)) (match List.length statuses with | 2 -> "both" diff --git a/src/source/source_tree.ml b/src/source/source_tree.ml index ba2a926bc80..2fa9598529b 100644 --- a/src/source/source_tree.ml +++ b/src/source/source_tree.ml @@ -67,11 +67,11 @@ module Dir0 = struct Dyn.record [ "path", Path.Source.to_dyn path ; "status", Source_dir_status.to_dyn status - ; "files", Dyn.Set (Filename.Array.Set.to_list_map files ~f:Dyn.string) + ; "files", Dyn.Set (Filename.Array.Set.to_list_map files ~f:Filename.to_dyn) ; ( "sub_dirs" , Dyn.Map (Filename.Array.Map.to_list_map sub_dirs ~f:(fun name sub_dir -> - Dyn.string name, dyn_of_sub_dir sub_dir)) ) + Filename.to_dyn name, dyn_of_sub_dir sub_dir)) ) ; ("dune_file", Dyn.(option opaque dune_file)) ] @@ -126,7 +126,7 @@ let rec physical match eval_status ~status_map ~parent_status fn with | None -> None | Some dir_status -> - let path = Path.Source.relative dir fn in + let path = Path.Source.relative_fname dir fn in let dirs_visited = Dirs_visited.add dirs_visited path file in Some { Dir0.sub_dir_status = dir_status @@ -167,7 +167,7 @@ and virtual_ ~project ~sub_dirs ~parent_status ~dune_file ~init ~path = Memo.lazy_cell (fun () -> find_dir_raw ~default_vcs:Dir0.Vcs.Ancestor_vcs - ~path:(Path.Source.relative path fn) + ~path:(Path.Source.relative_fname path fn) ~basename:fn ~virtual_:true ~dune_file @@ -338,7 +338,7 @@ let find_excluded_ancestor path = -> dir.dune_file |> Option.bind ~f:Dune_file.dirs_stanza_loc - |> Option.map ~f:(fun loc -> Path.Source.relative dir.path sub_dir, loc) + |> Option.map ~f:(fun loc -> Path.Source.relative_fname dir.path sub_dir, loc) | _ -> None)) in let* root = Memo.Cell.read root in @@ -354,7 +354,7 @@ let files_of path = | Some dir -> Dir0.filenames dir |> Filename.Array.Set.to_list - |> Path.Source.Set.of_list_map ~f:(Path.Source.relative path) + |> Path.Source.Set.of_list_map ~f:(Path.Source.relative_fname path) ;; module Dir = struct @@ -445,7 +445,10 @@ let ancestor_vcs = let dir = Filename.dirname dir in match let files = - Sys.readdir dir |> Stdlib.Array.to_list |> Filename.Array.Set.of_list + Sys.readdir dir + |> Stdlib.Array.to_list + |> List.map ~f:Filename.of_string_exn + |> Filename.Array.Set.of_list in Vcs.Kind.of_dir_contents ~files ~dirs:Filename.Array.Map.empty with diff --git a/src/source/workspace.ml b/src/source/workspace.ml index f94a8de06fe..0d9aa094866 100644 --- a/src/source/workspace.ml +++ b/src/source/workspace.ml @@ -472,7 +472,7 @@ module Context = struct | None -> "" | Some file -> let name, _ = Path.split_extension file in - "-fdo-" ^ Path.basename name + "-fdo-" ^ (Path.basename name |> Filename.to_string) ;; let decode = @@ -493,9 +493,11 @@ module Context = struct not disable and+ fdo_target_exe = let f file = - let ext = Filename.extension file in + let ext = + Stdlib.Filename.extension file |> Filename.Extension.Or_empty.of_string_exn + in if Filename.Extension.Or_empty.check ext Filename.Extension.exe - then Path.(relative root file) + then Path.relative Path.root file else User_error.raise [ Pp.concat @@ -814,7 +816,7 @@ let source_path_of_lock_dir_path path = match (path : Path.t) with | In_source_tree s -> s | In_build_dir b -> - (match Path.Build.explode b with + (match Path.Build.explode b |> Filename.L.to_string with | _ :: _ :: ".lock" :: (_ :: _ as lock_dir_segs) -> Path.Source.L.relative Path.Source.root lock_dir_segs | [ ".dev-tools.locks"; dev_tool ] -> @@ -1214,7 +1216,7 @@ let load_step1 clflags p = (step1 ~lang clflags))) ;; -let filename = "dune-workspace" +let filename = Filename.dune_workspace let workspace_step1 = let open Memo.O in @@ -1223,7 +1225,7 @@ let workspace_step1 = let* workspace_file = match clflags.workspace_file with | None -> - let p = Path.Outside_build_dir.of_string filename in + let p = Path.Outside_build_dir.of_string (Filename.to_string filename) in let+ exists = Fs_memo.file_exists p in Option.some_if exists p | Some p -> diff --git a/src/upgrader/dune_upgrader.ml b/src/upgrader/dune_upgrader.ml index a9d3f6efec7..0636fb2fc6d 100644 --- a/src/upgrader/dune_upgrader.ml +++ b/src/upgrader/dune_upgrader.ml @@ -162,7 +162,9 @@ module Common = struct | Some _ -> () | None -> let fn = - Path.Source.relative (Dune_project.root project) Dune_project.filename + Path.Source.relative + (Dune_project.root project) + (Filename.to_string Dune_project.filename) |> Path.source in Console.print [ Pp.textf "Creating %s..." (Path.to_string_maybe_quoted fn) ]; @@ -277,7 +279,7 @@ module V2 = struct if Filename.Array.Set.mem (Source_tree.Dir.filenames dir) Dune_file.fname then ( let path = Source_tree.Dir.path dir in - let fn = Path.Source.relative path Dune_file.fname in + let fn = Path.Source.relative_fname path Dune_file.fname in if Io.with_lexbuf_from_file (Path.source fn) ~f:Dune_lang.Dune_file_script.is_script then User_warning.emit @@ -334,7 +336,7 @@ end let detect_project_version project dir = let in_tree = Filename.Array.Set.mem (Source_tree.Dir.filenames dir) in Dune_project.default_dune_language_version := 0, 1; - if in_tree "jbuild" + if in_tree Filename.jbuild then ( let fn = Path.relative (Path.source (Source_tree.Dir.path dir)) "jbuild" in User_warning.emit diff --git a/test/expect-tests/dune_pkg/encode_decode_tests.ml b/test/expect-tests/dune_pkg/encode_decode_tests.ml index 7fc81707ff7..2ee1604d8ae 100644 --- a/test/expect-tests/dune_pkg/encode_decode_tests.ml +++ b/test/expect-tests/dune_pkg/encode_decode_tests.ml @@ -69,7 +69,7 @@ let lock_dir_encode_decode_round_trip_test ?commit ~lock_dir_path ~lock_dir () = let lock_dir_round_tripped = try Lock_dir.read_disk_exn lock_dir_path with | User_error.E _ as exn -> - let metadata_path = Path.relative lock_dir_path Lock_dir.metadata_filename in + let metadata_path = Path.relative_fname lock_dir_path Lock_dir.metadata_filename in let metadata_file_contents = Io.read_file metadata_path in print_endline "Failed to parse lockdir. Dumping raw metadata file to assist debugging."; diff --git a/test/expect-tests/dune_pkg/fetch_tests.ml b/test/expect-tests/dune_pkg/fetch_tests.ml index 51a8a148d71..8225e6292fe 100644 --- a/test/expect-tests/dune_pkg/fetch_tests.ml +++ b/test/expect-tests/dune_pkg/fetch_tests.ml @@ -191,6 +191,7 @@ let%expect_test "downloading, tarball with no checksum match" = print_endline "------\nfiles in target dir:"; Dune_engine.No_io.Path.Untracked.readdir_unsorted target |> Result.value ~default:[] + |> Filename.L.to_string |> List.sort ~compare:String.compare |> List.iter ~f:print_endline in diff --git a/test/expect-tests/dune_pkg/rev_store_fetch_depth/rev_store_fetch_depth_test.ml b/test/expect-tests/dune_pkg/rev_store_fetch_depth/rev_store_fetch_depth_test.ml index b1e2c6f6886..66b0593c6a6 100644 --- a/test/expect-tests/dune_pkg/rev_store_fetch_depth/rev_store_fetch_depth_test.ml +++ b/test/expect-tests/dune_pkg/rev_store_fetch_depth/rev_store_fetch_depth_test.ml @@ -71,9 +71,14 @@ let%expect_test "second fetch uses refs for efficient negotiation (fix #13323)" Unix.close sock; port in - let url = sprintf "git://127.0.0.1:%d/%s" port (Path.basename repo_dir) in + let url = + sprintf "git://127.0.0.1:%d/%s" port (Path.basename repo_dir |> Filename.to_string) + in let unrelated_url = - sprintf "git://127.0.0.1:%d/%s" port (Path.basename unrelated_repo_dir) + sprintf + "git://127.0.0.1:%d/%s" + port + (Path.basename unrelated_repo_dir |> Filename.to_string) in (* Run daemon in background while we do the test. The test cancels the build to kill the daemon, so we catch errors. *) diff --git a/test/expect-tests/dune_rules/cram_parsing_tests.ml b/test/expect-tests/dune_rules/cram_parsing_tests.ml index 70c2607c714..43a502d83d9 100644 --- a/test/expect-tests/dune_rules/cram_parsing_tests.ml +++ b/test/expect-tests/dune_rules/cram_parsing_tests.ml @@ -21,7 +21,7 @@ let test content = let test_file = Path.relative temp_dir "test.t" in Io.write_file test_file content; let lexbuf = Lexing.from_string ~with_positions:true content in - Stdlib.Lexing.set_filename lexbuf (Path.basename test_file); + Stdlib.Lexing.set_filename lexbuf (Path.basename test_file |> Filename.to_string); cram_stanzas lexbuf |> Pp.concat_map ~sep:Pp.cut ~f:(fun (loc, block) -> [ Loc.pp loc; dyn_of_block block |> Dyn.pp; Loc.to_dyn loc |> Dyn.pp ] diff --git a/test/unit-tests/which/dune b/test/unit-tests/which/dune index 16ef6e52600..0d56fbc5aca 100644 --- a/test/unit-tests/which/dune +++ b/test/unit-tests/which/dune @@ -2,7 +2,7 @@ (name which_tests) (enabled_if (= %{os_type} Win32)) - (libraries dyn dune_rules)) + (libraries dyn dune_rules stdune)) (alias (name runtest-windows) diff --git a/test/unit-tests/which/which_tests.ml b/test/unit-tests/which/which_tests.ml index 19d79fdfe06..9ee86397cf7 100644 --- a/test/unit-tests/which/which_tests.ml +++ b/test/unit-tests/which/which_tests.ml @@ -5,7 +5,8 @@ "prog.exe.exe". This test only runs on Windows (via enabled_if in dune). *) let test prog = - Dune_rules.For_tests.Which.candidates prog + Dune_rules.For_tests.Which.candidates (Stdune.Filename.of_string_exn prog) + |> Stdune.Filename.L.to_string |> Dyn.list Dyn.string |> Dyn.to_string |> Printf.printf "candidates %S = %s\n" prog