8bit.lol
forked from
futur.blue/pegasus
objective categorical abstract machine language personal data server
futur.blue
1open Hermes_cli
2
3(* recursively find all json files in a path (file or directory) *)
4let find_json_files path =
5 let rec aux acc p =
6 if Sys.is_directory p then
7 Sys.readdir p |> Array.to_list
8 |> List.map (Filename.concat p)
9 |> List.fold_left aux acc
10 else if Filename.check_suffix p ".json" then p :: acc
11 else acc
12 in
13 aux [] path
14
15(* generate module structure from lexicons *)
16let generate ~inputs ~output_dir ~module_name =
17 (* create output directory *)
18 if not (Sys.file_exists output_dir) then Sys.mkdir output_dir 0o755 ;
19 (* find all lexicon files from all inputs *)
20 let files = List.concat_map find_json_files inputs in
21 Printf.printf "Found %d lexicon files\n" (List.length files) ;
22 (* parse all files *)
23 let lexicons =
24 List.filter_map
25 (fun path ->
26 match Parser.parse_file path with
27 | Ok doc ->
28 Printf.printf " Parsed: %s\n" doc.Lexicon_types.id ;
29 Some doc
30 | Error e ->
31 Printf.eprintf " Error parsing %s: %s\n" path e ;
32 None )
33 files
34 in
35 Printf.printf "Successfully parsed %d lexicons\n" (List.length lexicons) ;
36 (* find file-level SCCs to detect cross-file cycles *)
37 let sccs = Scc.find_file_sccs lexicons in
38 Printf.printf "Found %d file-level SCCs\n" (List.length sccs) ;
39 (* track shared module index for unique naming *)
40 let shared_index = ref 0 in
41 (* generate each SCC *)
42 List.iter
43 (fun scc ->
44 match scc with
45 | [] ->
46 ()
47 | [doc] ->
48 (* single file, no cycle - generate normally *)
49 let code = Codegen.gen_lexicon_module doc in
50 let rel_path = Naming.file_path_of_nsid doc.Lexicon_types.id in
51 let full_path = Filename.concat output_dir rel_path in
52 let oc = open_out full_path in
53 output_string oc code ;
54 close_out oc ;
55 Printf.printf " Generated: %s\n" rel_path
56 | docs ->
57 (* multiple files forming a cycle - use shared module strategy *)
58 incr shared_index ;
59 let nsids = List.map (fun d -> d.Lexicon_types.id) docs in
60 Printf.printf " Cyclic lexicons: %s\n" (String.concat ", " nsids) ;
61 (* sort for consistent ordering *)
62 let sorted_docs =
63 List.sort
64 (fun a b -> String.compare a.Lexicon_types.id b.Lexicon_types.id)
65 docs
66 in
67 (* generate shared module with all types *)
68 let shared_module_name =
69 Naming.shared_module_name nsids !shared_index
70 in
71 let shared_file = Naming.shared_file_name nsids !shared_index in
72 let code = Codegen.gen_shared_module sorted_docs in
73 let full_path = Filename.concat output_dir shared_file in
74 let oc = open_out full_path in
75 output_string oc code ;
76 close_out oc ;
77 Printf.printf " Generated shared: %s\n" shared_file ;
78 (* generate re-export modules for each nsid *)
79 List.iter
80 (fun doc ->
81 let stub =
82 Codegen.gen_reexport_module ~shared_module_name
83 ~all_merged_docs:sorted_docs doc
84 in
85 let rel_path = Naming.file_path_of_nsid doc.Lexicon_types.id in
86 let full_path = Filename.concat output_dir rel_path in
87 let oc = open_out full_path in
88 output_string oc stub ;
89 close_out oc ;
90 Printf.printf " Generated: %s -> %s\n" rel_path
91 shared_module_name )
92 docs )
93 sccs ;
94 (* generate index file *)
95 let index_path =
96 Filename.concat output_dir (String.lowercase_ascii module_name ^ ".ml")
97 in
98 let oc = open_out index_path in
99 Printf.fprintf oc "(* %s - generated from atproto lexicons *)\n\n" module_name ;
100 (* export each lexicon as a module alias *)
101 List.iter
102 (fun doc ->
103 let flat_module = Naming.flat_module_name_of_nsid doc.Lexicon_types.id in
104 Printf.fprintf oc "module %s = %s\n" flat_module flat_module )
105 lexicons ;
106 close_out oc ;
107 Printf.printf "Generated index: %s\n" index_path ;
108 (* generate dune file *)
109 let dune_path = Filename.concat output_dir "dune" in
110 let oc = open_out dune_path in
111 Printf.fprintf oc "(library\n" ;
112 Printf.fprintf oc " (name %s)\n" (String.lowercase_ascii module_name) ;
113 Printf.fprintf oc " (libraries hermes yojson lwt)\n" ;
114 Printf.fprintf oc " (preprocess (pps ppx_deriving_yojson)))\n" ;
115 close_out oc ;
116 Printf.printf "Generated dune file\n" ;
117 Printf.printf "Done! Generated %d modules\n" (List.length lexicons)
118
119let inputs =
120 let doc = "lexicon files or directories to search recursively for JSON" in
121 Cmdliner.Arg.(non_empty & pos_all file [] & info [] ~docv:"INPUT" ~doc)
122
123let output_dir =
124 let doc = "output directory for generated code" in
125 Cmdliner.Arg.(
126 required & opt (some string) None & info ["o"; "output"] ~docv:"DIR" ~doc )
127
128let module_name =
129 let doc = "name of the generated module" in
130 Cmdliner.Arg.(
131 value
132 & opt string "Hermes_lexicons"
133 & info ["m"; "module-name"] ~docv:"NAME" ~doc )
134
135let generate_cmd =
136 let doc = "generate ocaml types from atproto lexicons" in
137 let info = Cmdliner.Cmd.info "generate" ~doc in
138 let generate' inputs output_dir module_name =
139 generate ~inputs ~output_dir ~module_name
140 in
141 Cmdliner.Cmd.v info
142 Cmdliner.Term.(const generate' $ inputs $ output_dir $ module_name)
143
144let main_cmd =
145 let doc = "hermes - atproto lexicon code generator" in
146 let info = Cmdliner.Cmd.info "hermes-cli" ~version:"0.1.0" ~doc in
147 Cmdliner.Cmd.group info [generate_cmd]
148
149let () = exit (Cmdliner.Cmd.eval main_cmd)