diff --git a/src/future.ml b/src/future.ml index be1d3f3f..23b3b1ab 100644 --- a/src/future.ml +++ b/src/future.ml @@ -365,41 +365,33 @@ module Scheduler = struct | 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 rec group_by_ext = function - | [] -> [] - | x :: xs -> - let eq_ext a b = - let chop s = - try Filename.chop_extension s with Invalid_argument _ -> s in - chop a = chop b in - let (similar, rest) = List.partition ~f:(eq_ext x) xs in - (x :: similar) :: group_by_ext rest in - let pp_ext ppf filename = - let ext = - match Filename.extension filename with - | "" -> "" - | s -> String.sub ~pos:1 ~len:(String.length s - 1) s - in - Format.fprintf ppf "%s" ext 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 = function + let pp_group ppf (prefix, suffixes) = + match suffixes with | [] -> assert false - | [s] -> Format.fprintf ppf "%s" s - | (x :: _) as group -> - Format.fprintf ppf "%s.{%a}" - (Filename.chop_extension x) - (Format.pp_print_list ~pp_sep:pp_comma pp_ext) - group in + | [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]@}" + (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) - (group_by_ext target_names) + target_names_grouped_by_prefix pp_contexts contexts; diff --git a/src/import.ml b/src/import.ml index 3d84c72b..1d74cd5b 100644 --- a/src/import.ml +++ b/src/import.ml @@ -165,6 +165,7 @@ module Map = struct | Error _ -> invalid_arg "Map.of_alist_exn" let of_alist_multi l = + let l = List.rev l in List.fold_left l ~init:empty ~f:(fun acc (key, data) -> add_multi acc ~key ~data) @@ -318,6 +319,15 @@ module Filename = struct (String.sub fn ~pos:0 ~len:i, String.sub fn ~pos:i ~len:(String.length fn - i)) + let split_extension_after_dot fn = + let i = extension_start fn + 1 in + let len = String.length fn in + if i > len then + (fn, "") + else + (String.sub fn ~pos:0 ~len:i, + String.sub fn ~pos:i ~len:(String.length fn - i)) + let extension fn = let i = extension_start fn in String.sub fn ~pos:i ~len:(String.length fn - i)