From dd79bdd8d16b8a9bd63908e6be8f967aae430935 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Fri, 12 May 2017 16:50:19 +0100 Subject: [PATCH] Suffix all alias files, to avoid clashes with doc --- src/alias.ml | 11 ++++- src/alias.mli | 2 + src/future.ml | 109 ++++++++++++++++++++++++----------------------- src/gen_rules.ml | 4 +- 4 files changed, 69 insertions(+), 57 deletions(-) diff --git a/src/alias.ml b/src/alias.ml index bb2ebc1a..6caa2055 100644 --- a/src/alias.ml +++ b/src/alias.ml @@ -17,13 +17,15 @@ type t = let aliases_path = Path.(relative root) "_build/.aliases" +let suffix = "-" ^ String.make 32 '0' + let of_path path = if not (Path.is_local path) then die "Aliases are only supported for local paths!\n\ Tried to reference alias %S" (Path.to_string path); { name = Name.make path - ; file = Path.append aliases_path path + ; file = Path.extend_basename (Path.append aliases_path path) ~suffix } let make name ~dir = of_path (Path.relative dir name) @@ -32,6 +34,13 @@ let dep t = Build.path t.file let file t = t.file +let file_with_digest_suffix t ~digest = + let dir = Path.parent t.file in + let base = Path.basename t.file in + let len = String.length base in + Path.relative dir + (String.sub base ~pos:0 ~len:(len - 32) ^ Digest.to_hex digest) + let default = make "DEFAULT" let runtest = make "runtest" let install = make "install" diff --git a/src/alias.mli b/src/alias.mli index 87204af5..515955cf 100644 --- a/src/alias.mli +++ b/src/alias.mli @@ -11,6 +11,8 @@ val lib_cm_all : dir:Path.t -> string -> Cm_kind.t -> t val dep : t -> ('a, 'a) Build.t val file : t -> Path.t +val file_with_digest_suffix : t -> digest:Digest.t -> Path.t + module Store : sig type t val create : unit -> t diff --git a/src/future.ml b/src/future.ml index cb2cc75e..b89256f6 100644 --- a/src/future.ml +++ b/src/future.ml @@ -335,65 +335,66 @@ module Scheduler = struct | File fn | Opened_file { filename = fn; _ } -> sprintf "%s 2> %s" s fn let pp_purpose ppf = function - | Internal_job -> - Format.fprintf ppf "(internal)" - | Build_job targets -> - let rec split_paths targets_acc ctxs_acc = function - | [] -> List.rev targets_acc, String_set.(elements (of_list ctxs_acc)) - | path :: rest -> + | Internal_job -> + Format.fprintf ppf "(internal)" + | Build_job targets -> + let rec split_paths targets_acc ctxs_acc = function + | [] -> List.rev targets_acc, String_set.(elements (of_list ctxs_acc)) + | path :: rest -> match Path.extract_build_context path with | None -> - split_paths (Path.to_string path :: targets_acc) ctxs_acc rest + split_paths (Path.to_string path :: targets_acc) ctxs_acc rest | Some ("default", filename) -> - split_paths (Path.to_string filename :: targets_acc) ctxs_acc rest + split_paths (Path.to_string filename :: targets_acc) ctxs_acc rest | Some (".aliases", filename) -> - let ctxs_acc, filename = match Path.extract_build_context filename with - | None -> ctxs_acc, Path.to_string filename - | Some (ctx, fn) -> - let strip_digest fn = - let fn = Path.to_string fn in - match String.rsplit2 fn ~on:'-' with - | None -> fn - | Some (name, digest) -> - match Digest.from_hex digest with - | _ -> name - | exception (Invalid_argument _) -> fn in - let ctxs_acc = - if ctx = "default" then ctxs_acc else ctx :: ctxs_acc in - ctxs_acc, strip_digest fn in - split_paths (("alias " ^ filename) :: targets_acc) ctxs_acc rest + let ctxs_acc, filename = + match Path.extract_build_context filename with + | None -> ctxs_acc, Path.to_string filename + | Some (ctx, fn) -> + let strip_digest fn = + let fn = Path.to_string fn in + match String.rsplit2 fn ~on:'-' with + | None -> assert false + | Some (name, digest) -> + assert (String.length digest = 32); + name + in + let ctxs_acc = + if ctx = "default" then ctxs_acc else ctx :: ctxs_acc in + ctxs_acc, strip_digest fn in + split_paths (("alias " ^ filename) :: targets_acc) ctxs_acc rest | Some (ctx, filename) -> - split_paths (Path.to_string filename :: targets_acc) (ctx :: ctxs_acc) rest in - let target_names, contexts = split_paths [] [] targets in - let target_names_grouped_by_prefix = - List.map target_names ~f:Filename.split_extension_after_dot - |> String_map.of_alist_multi - |> String_map.bindings - in - let pp_comma ppf () = Format.fprintf ppf "," in - let pp_group ppf (prefix, suffixes) = - match suffixes with - | [] -> assert false - | [suffix] -> Format.fprintf ppf "%s%s" prefix suffix - | _ -> - Format.fprintf ppf "%s{%a}" - prefix - (Format.pp_print_list ~pp_sep:pp_comma Format.pp_print_string) - suffixes - in - let pp_contexts ppf = function - | [] -> () - | ctxs -> - Format.fprintf ppf " @{
[%a]@}" - (Format.pp_print_list ~pp_sep:pp_comma - (fun ppf s -> Format.fprintf ppf "%s" s)) - ctxs - in - Format.fprintf ppf "%a%a" - (Format.pp_print_list ~pp_sep:pp_comma pp_group) - target_names_grouped_by_prefix - pp_contexts - contexts; + split_paths (Path.to_string filename :: targets_acc) (ctx :: ctxs_acc) rest in + let target_names, contexts = split_paths [] [] targets in + let target_names_grouped_by_prefix = + List.map target_names ~f:Filename.split_extension_after_dot + |> String_map.of_alist_multi + |> String_map.bindings + in + let pp_comma ppf () = Format.fprintf ppf "," in + let pp_group ppf (prefix, suffixes) = + match suffixes with + | [] -> assert false + | [suffix] -> Format.fprintf ppf "%s%s" prefix suffix + | _ -> + Format.fprintf ppf "%s{%a}" + prefix + (Format.pp_print_list ~pp_sep:pp_comma Format.pp_print_string) + suffixes + in + let pp_contexts ppf = function + | [] -> () + | ctxs -> + Format.fprintf ppf " @{
[%a]@}" + (Format.pp_print_list ~pp_sep:pp_comma + (fun ppf s -> Format.fprintf ppf "%s" s)) + ctxs + in + Format.fprintf ppf "%a%a" + (Format.pp_print_list ~pp_sep:pp_comma pp_group) + target_names_grouped_by_prefix + pp_contexts + contexts; type running_job = { id : int diff --git a/src/gen_rules.ml b/src/gen_rules.ml index eec3979f..152fcee6 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -489,9 +489,9 @@ module Gen(P : Params) = struct Sexp.List [deps ; action] |> Sexp.to_string |> Digest.string - |> Digest.to_hex in + in let alias = Alias.make alias_conf.name ~dir in - let digest_path = Path.extend_basename (Alias.file alias) ~suffix:("-" ^ digest) in + let digest_path = Alias.file_with_digest_suffix alias ~digest in Alias.add_deps (SC.aliases sctx) alias [digest_path]; let deps = SC.Deps.interpret sctx ~dir alias_conf.deps in SC.add_rule sctx