File: hier.ml

package info (click to toggle)
ocaml-obuild 0.2.2-1
  • links: PTS, VCS
  • area: main
  • in suites: forky, sid
  • size: 1,456 kB
  • sloc: ml: 14,491; sh: 211; ansic: 34; makefile: 11
file content (248 lines) | stat: -rw-r--r-- 8,902 bytes parent folder | download
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 ]