1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248
|
open Fugue
open Filepath
open Compat
exception EmptyModuleHierarchy
type t = Modname.t list
(* first filepath is the source path, second is the actual path *)
type file_entry =
| FileEntry of (filepath * filepath) (* root_path, full_path *)
| GeneratedFileEntry of (filepath * filepath * filename)
(* root_path, full_path, generated_path *)
| DirectoryEntry of (filepath * filepath)
(* root_path, full_path *)
let file_entry_to_string = function
| FileEntry (p, f) -> Printf.sprintf "FileEntry %s %s" (fp_to_string p) (fp_to_string f)
| DirectoryEntry (p, f) -> Printf.sprintf "DirectoryEntry %s %s" (fp_to_string p) (fp_to_string f)
| GeneratedFileEntry (p, f, n) ->
Printf.sprintf "GeneratedFileEntry %s %s %s" (fp_to_string p) (fp_to_string f)
(fn_to_string n)
let hiers : (t, file_entry) Hashtbl.t = Hashtbl.create 128
(* Global registry of generated module names (from generate blocks across all targets) *)
let generated_modules : (string, unit) Hashtbl.t = Hashtbl.create 16
let register_generated_module name =
Hashtbl.replace generated_modules name ()
let is_generated_module name =
Hashtbl.mem generated_modules name
let clear () =
Hashtbl.clear hiers;
Hashtbl.clear generated_modules
let root = function
| x :: _ -> x
| [] -> raise EmptyModuleHierarchy
let parent x =
match x with
| [] -> assert false
| [ _ ] -> None
| l -> Some (list_init l)
let leaf = list_last
let make l = if l = [] then raise EmptyModuleHierarchy else l
let lvl x = List.length x - 1
let to_string x = String.concat "." (List.map Modname.to_string x)
let of_string x =
let l = String_utils.split '.' x in
make (List.map Modname.of_string l)
let ml_to_ext path ext =
let f = path_basename path in
let d = path_dirname path in
d </> (chop_extension f <.> Filetype.to_string ext)
let of_modname x = [ x ]
let to_node x = x
let to_dirpath x =
match x with
| [] | [_] -> current_dir
| _ -> fp (String.concat Filename.dir_sep (List.map Modname.to_dir $ list_init x))
let append x m = x @ [ m ]
let add_prefix prefix_path hier =
match hier with
| [] | [_] -> prefix_path
| _ ->
let to_fp = fp (String.concat Filename.dir_sep (List.map Modname.to_dir $ list_init hier)) in
if path_length prefix_path = 0 then
to_fp
else
let rec loop path hier_list =
match hier_list with
| [] -> path <//> to_fp
| x :: xs ->
if path_basename path = fn (Modname.to_dir x) then
if path_length prefix_path = 1 then
to_fp (* prefix_path is fully included in hier *)
else
loop (path_dirname path) xs
else
path <//> to_fp
in
loop prefix_path (List.tl (List.rev hier))
let check_file path filename ext =
if ext <> Filetype.FileOther "" then
Filesystem.exists (path </> (fn filename <.> Filetype.to_string ext))
else
Filesystem.exists (path </> fn filename)
let check_modname path modname ext =
if check_file path modname ext then
Some modname
else
let name = string_uncapitalize modname in
if check_file path name ext then
Some name
else
None
let get_filepath root_path hier ext : file_entry option =
match SafeHashtbl.find_opt hiers hier with
| Some entry -> Some entry
| None -> (
let path = add_prefix root_path hier in
let modname = Modname.to_string (leaf hier) in
let res = check_modname path modname ext in
match res with
| None -> None
| Some name ->
let entry =
if ext <> Filetype.FileOther "" then
FileEntry (root_path, path </> (fn name <.> Filetype.to_string ext))
else
DirectoryEntry (root_path, path </> fn name)
in
Hashtbl.add hiers hier entry;
Some entry)
let to_filename hier prefix_path = get_filepath prefix_path hier Filetype.FileML
let to_directory hier prefix_path = get_filepath prefix_path hier (Filetype.FileOther "")
let to_generators hier prefix_path =
match SafeHashtbl.find_opt hiers hier with
| Some entry -> Some entry
| None -> (
try
Some
(list_find_map
(fun gen ->
let path = add_prefix prefix_path hier in
let modname_t = leaf hier in
let modname_t = gen.Generators.modname modname_t in
let modname_str = Modname.to_string modname_t in
let ext = Filetype.FileOther gen.Generators.suffix in
let res = check_modname path modname_str ext in
match res with
| None -> None
| Some name ->
let filename = fn name <.> Filetype.to_string ext in
let fullname = path </> filename in
let generated_file =
gen.Generators.generated_files filename (Modname.to_string (leaf hier))
in
Hashtbl.add hiers hier
(GeneratedFileEntry (prefix_path, fullname, generated_file));
Some (GeneratedFileEntry (prefix_path, fullname, generated_file)))
(Generators.get_all ()))
with Not_found -> None)
let get_src_file dst_dir = function
| FileEntry (_, f) -> f
| GeneratedFileEntry (_, _, fn) -> dst_dir </> fn
| DirectoryEntry (_, f) -> f
let get_dest_file dst_dir ext hier =
let entry =
match SafeHashtbl.find_opt hiers hier with
| Some e -> e
| None -> raise Not_found
in
match entry with
| FileEntry (_, f) ->
let filename = path_basename f in
let path = add_prefix dst_dir hier in
path </> (chop_extension filename <.> Filetype.to_string ext)
| GeneratedFileEntry (_, _, filename) ->
let path = add_prefix dst_dir hier in
path </> (chop_extension filename <.> Filetype.to_string ext)
| DirectoryEntry (_, f) ->
let filename = path_basename f in
let path = add_prefix dst_dir hier in
path </> (filename <.> Filetype.to_string ext)
let get_dest_file_ext dst_dir hier ext_f =
let entry =
match SafeHashtbl.find_opt hiers hier with
| Some e -> e
| None -> raise Not_found
in
match entry with
| FileEntry (_, f) ->
let filename = path_basename f in
let filetype = Filetype.of_filepath f in
let path = add_prefix dst_dir hier in
path </> (chop_extension filename <.> Filetype.to_string (ext_f filetype))
| GeneratedFileEntry (_, _, filename) ->
let path = add_prefix dst_dir hier in
let filetype = Filetype.of_filename filename in
path </> (chop_extension filename <.> Filetype.to_string (ext_f filetype))
| DirectoryEntry (_, f) ->
let filename = path_basename f in
let path = add_prefix dst_dir hier in
let filetype = Filetype.of_filepath f in
path </> (filename <.> Filetype.to_string (ext_f filetype))
let to_interface hier prefix_path = get_filepath prefix_path hier Filetype.FileMLI
let get_file_entry_maybe hier = SafeHashtbl.find_opt hiers hier
let get_file_entry hier paths =
match SafeHashtbl.find_opt hiers hier with
| Some entry -> entry
| None ->
list_find_map
(fun path ->
try
Some
(list_find_map
(fun lookup -> lookup hier path)
[ to_filename; to_directory; to_generators; to_interface ])
with Not_found -> None)
paths
(* Register a synthetic file entry for modules that will be generated during build
(e.g., cstubs-generated modules, generate-block modules). This allows get_dest_file
to work for these modules even before the source file exists.
This function REPLACES any existing entry because during dependency analysis
a directory or other entry might have been cached before we knew it was synthetic. *)
let register_synthetic_entry hier root_path full_path =
Hashtbl.replace hiers hier (FileEntry (root_path, full_path))
(* Register a generated file entry for modules produced by generators (e.g., atdgen).
This allows modules like Ollama_t (from ollama.atd) to be discovered.
- hier: the module hierarchy (e.g., Ollama_t)
- root_path: the source directory containing the generator input
- src_path: full path to the source file (e.g., lib/ollama.atd)
- output_file: the generated output filename (e.g., ollama_t.ml) *)
let register_generated_entry hier root_path src_path output_file =
Hashtbl.replace hiers hier (GeneratedFileEntry (root_path, src_path, output_file))
let of_filename filename =
let name = Filename.chop_extension (fn_to_string filename) in
let m =
try Modname.wrap (string_capitalize name) with
| Modname.EmptyModuleName -> raise (Modname.ModuleFilenameNotValid (fn_to_string filename))
| Invalid_argument _ -> raise (Modname.ModuleFilenameNotValid (fn_to_string filename))
in
make [ m ]
|