futur.blue
objective categorical abstract machine language personal data server
1open Hermes_cli
2
3let dune_file =
4 Printf.sprintf
5 {|(library
6 (name %s)
7 (libraries hermes yojson lwt)
8 (preprocess (pps ppx_deriving_yojson)))|}
9
10let util_file =
11 Printf.sprintf
12 {|let query_string_list_of_yojson = function
13 | `List l ->
14 Ok (List.filter_map (function `String s -> Some s | _ -> None) l)
15 | `String s ->
16 Ok [s]
17 | `Null ->
18 Ok []
19 | _ ->
20 Error "expected string or string list"
21
22let query_string_list_to_yojson l = `List (List.map (fun s -> `String s) l)
23
24let query_int_list_of_yojson = function
25 | `List l ->
26 Ok (List.filter_map (function `Int i -> Some i | _ -> None) l)
27 | `Int i ->
28 Ok [i]
29 | `Null ->
30 Ok []
31 | _ ->
32 Error "expected int or int list"
33
34let query_int_list_to_yojson l = `List (List.map (fun i -> `Int i) l)
35
36let query_string_list_option_of_yojson = function
37 | `List l ->
38 Ok (Some (List.filter_map (function `String s -> Some s | _ -> None) l))
39 | `String s ->
40 Ok (Some [s])
41 | `Null ->
42 Ok None
43 | _ ->
44 Error "expected string or string list"
45
46let query_string_list_option_to_yojson = function
47 | Some l ->
48 `List (List.map (fun s -> `String s) l)
49 | None ->
50 `Null
51
52let query_int_list_option_of_yojson = function
53 | `List l ->
54 Ok (Some (List.filter_map (function `Int i -> Some i | _ -> None) l))
55 | `Int i ->
56 Ok (Some [i])
57 | `Null ->
58 Ok None
59 | _ ->
60 Error "expected int or int list"
61
62let query_int_list_option_to_yojson = function
63 | Some l ->
64 `List (List.map (fun i -> `Int i) l)
65 | None ->
66 `Null|}
67
68(* recursively find all json files in a path (file or directory) *)
69let find_json_files path =
70 let rec aux acc p =
71 if Sys.is_directory p then
72 Sys.readdir p |> Array.to_list
73 |> List.map (Filename.concat p)
74 |> List.fold_left aux acc
75 else if Filename.check_suffix p ".json" then p :: acc
76 else acc
77 in
78 aux [] path
79
80let generate_index lexicons =
81 let nsids = List.map (fun lexicon -> lexicon.Lexicon_types.id) lexicons in
82 let trie = Naming.group_nsids_by_prefix nsids in
83 let rec build_index (trie : Naming.trie) index indent =
84 match trie with
85 | Node children ->
86 List.fold_left
87 (fun acc (key, child) ->
88 match (child : Naming.trie) with
89 | Module nsid ->
90 let module_name = Naming.flat_module_name_of_nsid nsid in
91 acc ^ indent
92 ^ Printf.sprintf "module %s = %s\n"
93 (String.capitalize_ascii key)
94 module_name
95 | Node _ ->
96 acc ^ indent
97 ^ Printf.sprintf "module %s = struct\n"
98 (String.capitalize_ascii key)
99 ^ build_index child index (indent ^ " ")
100 ^ indent ^ "end\n" )
101 index children
102 | _ ->
103 failwith "build_index called with invalid trie"
104 in
105 build_index (Node trie) "" ""
106
107(* generate module structure from lexicons *)
108let generate ~inputs ~output_dir ~module_name =
109 (* create output directory *)
110 if not (Sys.file_exists output_dir) then Sys.mkdir output_dir 0o755 ;
111 (* find all lexicon files from all inputs *)
112 let files = List.concat_map find_json_files inputs in
113 Printf.printf "Found %d lexicon files\n" (List.length files) ;
114 (* parse all files *)
115 let lexicons =
116 List.filter_map
117 (fun path ->
118 match Parser.parse_file path with
119 | Ok doc ->
120 Printf.printf " Parsed: %s\n" doc.Lexicon_types.id ;
121 Some doc
122 | Error e ->
123 Printf.eprintf " Error parsing %s: %s\n" path e ;
124 None )
125 files
126 in
127 Printf.printf "Successfully parsed %d lexicons\n" (List.length lexicons) ;
128 (* find file-level SCCs to detect cross-file cycles *)
129 let sccs = Scc.find_file_sccs lexicons in
130 Printf.printf "Found %d file-level SCCs\n" (List.length sccs) ;
131 (* track shared module index for unique naming *)
132 let shared_index = ref 0 in
133 (* generate each SCC *)
134 List.iter
135 (fun scc ->
136 match scc with
137 | [] ->
138 ()
139 | [doc] ->
140 (* single file, no cycle - generate normally *)
141 let code = Codegen.gen_lexicon_module doc in
142 let rel_path = Naming.file_path_of_nsid doc.Lexicon_types.id in
143 let full_path = Filename.concat output_dir rel_path in
144 let oc = open_out full_path in
145 output_string oc code ;
146 close_out oc ;
147 Printf.printf " Generated: %s\n" rel_path
148 | docs ->
149 (* multiple files forming a cycle - use shared module strategy *)
150 incr shared_index ;
151 let nsids = List.map (fun d -> d.Lexicon_types.id) docs in
152 Printf.printf " Cyclic lexicons: %s\n" (String.concat ", " nsids) ;
153 (* sort for consistent ordering *)
154 let sorted_docs =
155 List.sort
156 (fun a b -> String.compare a.Lexicon_types.id b.Lexicon_types.id)
157 docs
158 in
159 (* generate shared module with all types *)
160 let shared_module_name =
161 Naming.shared_module_name nsids !shared_index
162 in
163 let shared_file = Naming.shared_file_name nsids !shared_index in
164 let code = Codegen.gen_shared_module sorted_docs in
165 let full_path = Filename.concat output_dir shared_file in
166 let oc = open_out full_path in
167 output_string oc code ;
168 close_out oc ;
169 Printf.printf " Generated shared: %s\n" shared_file ;
170 (* generate re-export modules for each nsid *)
171 List.iter
172 (fun doc ->
173 let stub =
174 Codegen.gen_reexport_module ~shared_module_name
175 ~all_merged_docs:sorted_docs doc
176 in
177 let rel_path = Naming.file_path_of_nsid doc.Lexicon_types.id in
178 let full_path = Filename.concat output_dir rel_path in
179 let oc = open_out full_path in
180 output_string oc stub ;
181 close_out oc ;
182 Printf.printf " Generated: %s -> %s\n" rel_path
183 shared_module_name )
184 docs )
185 sccs ;
186 (* generate index file *)
187 let index_path =
188 Filename.concat output_dir (String.lowercase_ascii module_name ^ ".ml")
189 in
190 let oc = open_out index_path in
191 Printf.fprintf oc "(* %s - generated from atproto lexicons *)\n\n" module_name ;
192 (* export each lexicon as a module alias *)
193 Out_channel.output_string oc (generate_index lexicons) ;
194 close_out oc ;
195 Printf.printf "Generated index: %s\n" index_path ;
196 (* generate dune file *)
197 let dune_path = Filename.concat output_dir "dune" in
198 let oc = open_out dune_path in
199 Out_channel.output_string oc (dune_file (String.lowercase_ascii module_name)) ;
200 close_out oc ;
201 Printf.printf "Generated dune file\n" ;
202 (* generate util file *)
203 let util_path = Filename.concat output_dir "hermes_util.ml" in
204 let oc = open_out util_path in
205 Printf.fprintf oc "(* %s - generated from atproto lexicons *)\n\n" module_name ;
206 (* export each lexicon as a module alias *)
207 Out_channel.output_string oc util_file ;
208 close_out oc ;
209 Printf.printf "Generated util file: %s\n" util_path ;
210 Printf.printf "Done! Generated %d modules\n" (List.length lexicons)
211
212let inputs =
213 let doc = "lexicon files or directories to search recursively for JSON" in
214 Cmdliner.Arg.(non_empty & pos_all file [] & info [] ~docv:"INPUT" ~doc)
215
216let output_dir =
217 let doc = "output directory for generated code" in
218 Cmdliner.Arg.(
219 required & opt (some string) None & info ["o"; "output"] ~docv:"DIR" ~doc )
220
221let module_name =
222 let doc = "name of the generated module" in
223 Cmdliner.Arg.(
224 value
225 & opt string "Hermes_lexicons"
226 & info ["m"; "module-name"] ~docv:"NAME" ~doc )
227
228let generate_cmd =
229 let doc = "generate ocaml types from atproto lexicons" in
230 let info = Cmdliner.Cmd.info "generate" ~doc in
231 let generate' inputs output_dir module_name =
232 generate ~inputs ~output_dir ~module_name
233 in
234 Cmdliner.Cmd.v info
235 Cmdliner.Term.(const generate' $ inputs $ output_dir $ module_name)
236
237let main_cmd =
238 let doc = "hermes - atproto lexicon code generator" in
239 let info = Cmdliner.Cmd.info "hermes-cli" ~version:"0.1.0" ~doc in
240 Cmdliner.Cmd.group info [generate_cmd]
241
242let () = exit (Cmdliner.Cmd.eval main_cmd)