let path ~readable_suffix ~from high_level_components =
let sanitize =
String.map
~f:(function
| ('a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '-') as c -> c
| other -> '_') in
let components =
begin match from with
| `Path p ->
let b = Filename.basename p in
(try [Filename.chop_extension b] with _ -> [b])
| `In_dir d -> []
end
@
List.map high_level_components ~f:sanitize
in
let hash =
String.concat ~sep:"-" (readable_suffix :: components)
|> Digest.string |> Digest.to_hex
in
let max_length = 220 in
let buf = Buffer.create max_length in
Buffer.add_string buf hash;
let rec append_components =
function
| [] -> ()
| one :: more ->
if
Buffer.length buf + String.length readable_suffix
+ String.length one < max_length
then (Buffer.add_string buf one; append_components more)
else ()
in
append_components components;
Buffer.add_string buf readable_suffix;
let name = Buffer.contents buf in
begin if String.length name > max_length then
ksprintf failwith "Name_file: filename too long %s (max: %d)"
name max_length
end;
begin match Hashtbl.find db name with
| some
when List.sort ~cmp:String.compare some
= List.sort ~cmp:String.compare components -> ()
| some ->
ksprintf failwith "Duplicate filename for different components\nFilename: %s\nPrevious: [%s]\nNew: [%s]\n"
name (String.concat ~sep:", " some) (String.concat ~sep:", " components)
| exception _ ->
Hashtbl.add db name components
end;
begin match from with
| `In_dir s -> s // name
| `Path p -> Filename.dirname p // name
end