anil.recoil.org
Monorepo management for opam overlays
Tidy OCaml code and add release metadata
Code improvements:
- Use String.starts_with/ends_with instead of manual prefix/suffix checks
- Consolidate ensure_claude_md/ensure_gitignore into ensure_file helper
- Simplify discover_packages, find_package, status with Result combinators
- Simplify get_branch using Option.bind
- Apply ocamlformat for consistent code style
Release metadata:
- Add LICENSE file (ISC)
- Add .ocamlformat configuration
- Ensure x-maintenance-intent is in opam file
Co-Authored-By: Claude Opus 4.5 <noreply@anthropic.com>
+15
LICENSE
+15
LICENSE
···
1
+
ISC License
2
+
3
+
Copyright (c) 2024 Anil Madhavapeddy <anil@recoil.org>
4
+
5
+
Permission to use, copy, modify, and/or distribute this software for any
6
+
purpose with or without fee is hereby granted, provided that the above
7
+
copyright notice and this permission notice appear in all copies.
8
+
9
+
THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH
10
+
REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY
11
+
AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,
12
+
INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
13
+
LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR
14
+
OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
15
+
PERFORMANCE OF THIS SOFTWARE.
+190
-106
bin/main.ml
+190
-106
bin/main.ml
···
9
9
Term.(const setup_logging $ Fmt_cli.style_renderer () $ Logs_cli.level ())
10
10
11
11
let config_file_arg =
12
-
let doc = "Path to config file. If not specified, searches current directory then XDG locations." in
13
-
Arg.(value & opt (some string) None & info [ "c"; "config" ] ~docv:"FILE" ~doc)
12
+
let doc =
13
+
"Path to config file. If not specified, searches current directory then \
14
+
XDG locations."
15
+
in
16
+
Arg.(
17
+
value & opt (some string) None & info [ "c"; "config" ] ~docv:"FILE" ~doc)
14
18
15
19
let package_arg =
16
20
let doc = "Package name. If not specified, operates on all packages." in
···
26
30
if Fpath.is_abs load_path then
27
31
Monopam.Config.load ~fs ~root_fs:fs load_path
28
32
else
29
-
match Monopam.Config.load ~fs:(cwd :> _ Eio.Path.t) ~root_fs:fs load_path with
33
+
match
34
+
Monopam.Config.load ~fs:(cwd :> _ Eio.Path.t) ~root_fs:fs load_path
35
+
with
30
36
| Ok c -> Ok c
31
37
| Error msg -> Error msg)
32
38
| None -> (
33
39
(* Try current directory first *)
34
40
let cwd_config = Fpath.v "monopam.toml" in
35
-
match Monopam.Config.load ~fs:(cwd :> _ Eio.Path.t) ~root_fs:fs cwd_config with
41
+
match
42
+
Monopam.Config.load ~fs:(cwd :> _ Eio.Path.t) ~root_fs:fs cwd_config
43
+
with
36
44
| Ok c -> Ok c
37
-
| Error _ ->
45
+
| Error _ -> (
38
46
(* Try XDG *)
39
47
let xdg = Xdge.create fs "monopam" in
40
48
match Monopam.Config.load_xdg ~xdg () with
41
49
| Ok c -> Ok c
42
-
| Error msg -> Error msg)
50
+
| Error msg -> Error msg))
43
51
44
52
let with_config env config_file f =
45
53
match load_config env config_file with
···
52
60
53
61
let status_cmd =
54
62
let doc = "Show synchronization status of all packages" in
55
-
let man = [
56
-
`S Manpage.s_description;
57
-
`P "Displays the status of each package discovered in the opam overlay. \
58
-
For each package, shows whether the checkout is clean or has local \
59
-
changes, and whether the subtree is present in the monorepo.";
60
-
`P "Status indicators:";
61
-
`I ("clean", "Checkout matches remote, no local changes");
62
-
`I ("ahead N, behind M", "Checkout has N unpushed commits and is M commits behind remote");
63
-
`I ("present", "Subtree exists in monorepo");
64
-
`I ("missing", "Subtree not yet added to monorepo");
65
-
] in
63
+
let man =
64
+
[
65
+
`S Manpage.s_description;
66
+
`P
67
+
"Displays the status of each package discovered in the opam overlay. \
68
+
For each package, shows whether the checkout is clean or has local \
69
+
changes, and whether the subtree is present in the monorepo.";
70
+
`P "Status indicators:";
71
+
`I ("clean", "Checkout matches remote, no local changes");
72
+
`I
73
+
( "ahead N, behind M",
74
+
"Checkout has N unpushed commits and is M commits behind remote" );
75
+
`I ("present", "Subtree exists in monorepo");
76
+
`I ("missing", "Subtree not yet added to monorepo");
77
+
]
78
+
in
66
79
let info = Cmd.info "status" ~doc ~man in
67
80
let run config_file () =
68
81
Eio_main.run @@ fun env ->
···
83
96
84
97
let pull_cmd =
85
98
let doc = "Pull updates from remotes into monorepo" in
86
-
let man = [
87
-
`S Manpage.s_description;
88
-
`P "Fetches the latest changes from git remotes and updates both the \
89
-
individual checkouts and the monorepo subtrees.";
90
-
`P "For each unique repository:";
91
-
`I ("1.", "Clones the repository if not present, or fetches and fast-forward merges");
92
-
`I ("2.", "Adds or pulls the git subtree into the monorepo");
93
-
`P "If a specific package is given, only that package's repository is processed.";
94
-
`P "The operation will fail if any checkout has uncommitted changes.";
95
-
] in
99
+
let man =
100
+
[
101
+
`S Manpage.s_description;
102
+
`P
103
+
"Fetches the latest changes from git remotes and updates both the \
104
+
individual checkouts and the monorepo subtrees.";
105
+
`P "For each unique repository:";
106
+
`I
107
+
( "1.",
108
+
"Clones the repository if not present, or fetches and fast-forward \
109
+
merges" );
110
+
`I ("2.", "Adds or pulls the git subtree into the monorepo");
111
+
`P
112
+
"If a specific package is given, only that package's repository is \
113
+
processed.";
114
+
`P "The operation will fail if any checkout has uncommitted changes.";
115
+
]
116
+
in
96
117
let info = Cmd.info "pull" ~doc ~man in
97
118
let run config_file package () =
98
119
Eio_main.run @@ fun env ->
···
107
128
Fmt.epr "Error: %a@." Monopam.pp_error e;
108
129
`Error (false, "pull failed")
109
130
in
110
-
Cmd.v info Term.(ret (const run $ config_file_arg $ package_arg $ logging_term))
131
+
Cmd.v info
132
+
Term.(ret (const run $ config_file_arg $ package_arg $ logging_term))
111
133
112
134
(* Push command *)
113
135
114
136
let push_cmd =
115
137
let doc = "Push changes from monorepo to checkouts" in
116
-
let man = [
117
-
`S Manpage.s_description;
118
-
`P "Extracts changes made in the monorepo and merges them into the \
119
-
individual git checkouts using git subtree split.";
120
-
`P "For each unique repository:";
121
-
`I ("1.", "Splits the subtree commits from the monorepo");
122
-
`I ("2.", "Fast-forward merges the split commits into the checkout");
123
-
`P "After running push, you can review the changes in each checkout \
124
-
and manually push them to the git remotes.";
125
-
`P "The operation will fail if any checkout has uncommitted changes.";
126
-
] in
138
+
let man =
139
+
[
140
+
`S Manpage.s_description;
141
+
`P
142
+
"Extracts changes made in the monorepo and merges them into the \
143
+
individual git checkouts using git subtree split.";
144
+
`P "For each unique repository:";
145
+
`I ("1.", "Splits the subtree commits from the monorepo");
146
+
`I ("2.", "Fast-forward merges the split commits into the checkout");
147
+
`P
148
+
"After running push, you can review the changes in each checkout and \
149
+
manually push them to the git remotes.";
150
+
`P "The operation will fail if any checkout has uncommitted changes.";
151
+
]
152
+
in
127
153
let info = Cmd.info "push" ~doc ~man in
128
154
let run config_file package () =
129
155
Eio_main.run @@ fun env ->
···
138
164
Fmt.epr "Error: %a@." Monopam.pp_error e;
139
165
`Error (false, "push failed")
140
166
in
141
-
Cmd.v info Term.(ret (const run $ config_file_arg $ package_arg $ logging_term))
167
+
Cmd.v info
168
+
Term.(ret (const run $ config_file_arg $ package_arg $ logging_term))
142
169
143
170
(* Add command *)
144
171
145
172
let add_cmd =
146
173
let doc = "Add a package to the monorepo" in
147
-
let man = [
148
-
`S Manpage.s_description;
149
-
`P "Adds a single package from the opam overlay to the monorepo.";
150
-
`P "This clones the package's git repository if not already present, \
151
-
then adds it as a git subtree in the monorepo.";
152
-
] in
174
+
let man =
175
+
[
176
+
`S Manpage.s_description;
177
+
`P "Adds a single package from the opam overlay to the monorepo.";
178
+
`P
179
+
"This clones the package's git repository if not already present, then \
180
+
adds it as a git subtree in the monorepo.";
181
+
]
182
+
in
153
183
let info = Cmd.info "add" ~doc ~man in
154
184
let package_arg =
155
185
let doc = "Package name to add" in
···
168
198
Fmt.epr "Error: %a@." Monopam.pp_error e;
169
199
`Error (false, "add failed")
170
200
in
171
-
Cmd.v info Term.(ret (const run $ config_file_arg $ package_arg $ logging_term))
201
+
Cmd.v info
202
+
Term.(ret (const run $ config_file_arg $ package_arg $ logging_term))
172
203
173
204
(* Remove command *)
174
205
175
206
let remove_cmd =
176
207
let doc = "Remove a package from the monorepo" in
177
-
let man = [
178
-
`S Manpage.s_description;
179
-
`P "Removes a package's subtree directory from the monorepo.";
180
-
`P "This does not delete the git checkout - only the subtree in the monorepo.";
181
-
] in
208
+
let man =
209
+
[
210
+
`S Manpage.s_description;
211
+
`P "Removes a package's subtree directory from the monorepo.";
212
+
`P
213
+
"This does not delete the git checkout - only the subtree in the \
214
+
monorepo.";
215
+
]
216
+
in
182
217
let info = Cmd.info "remove" ~doc ~man in
183
218
let package_arg =
184
219
let doc = "Package name to remove" in
···
197
232
Fmt.epr "Error: %a@." Monopam.pp_error e;
198
233
`Error (false, "remove failed")
199
234
in
200
-
Cmd.v info Term.(ret (const run $ config_file_arg $ package_arg $ logging_term))
235
+
Cmd.v info
236
+
Term.(ret (const run $ config_file_arg $ package_arg $ logging_term))
201
237
202
238
(* Init command *)
203
239
204
240
let prompt_path ~stdin ~stdout ~cwd prompt ~default =
205
-
let default_str = match default with Some d -> Fmt.str " [%a]" Fpath.pp d | None -> "" in
241
+
let default_str =
242
+
match default with Some d -> Fmt.str " [%a]" Fpath.pp d | None -> ""
243
+
in
206
244
Eio.Flow.copy_string (Fmt.str "%s%s: " prompt default_str) stdout;
207
245
let input = String.trim (Eio.Buf_read.line stdin) in
208
-
let input = if input = "" then Option.map Fpath.to_string default else Some input in
246
+
let input =
247
+
if input = "" then Option.map Fpath.to_string default else Some input
248
+
in
209
249
match input with
210
250
| None -> Error "Path is required"
211
-
| Some s ->
251
+
| Some s -> (
212
252
(* Expand tilde *)
213
253
let s =
214
254
if String.length s > 0 && s.[0] = '~' then
215
255
match Sys.getenv_opt "HOME" with
216
256
| Some home ->
217
257
if String.length s = 1 then home
218
-
else if s.[1] = '/' then home ^ String.sub s 1 (String.length s - 1)
258
+
else if s.[1] = '/' then
259
+
home ^ String.sub s 1 (String.length s - 1)
219
260
else s
220
261
| None -> s
221
262
else s
···
225
266
| Ok path ->
226
267
(* Convert relative to absolute using cwd *)
227
268
let path =
228
-
if Fpath.is_abs path then path
229
-
else Fpath.(cwd // path |> normalize)
269
+
if Fpath.is_abs path then path else Fpath.(cwd // path |> normalize)
230
270
in
231
-
Ok path
271
+
Ok path)
232
272
233
273
let init_cmd =
234
274
let doc = "Initialize a new monopam configuration" in
235
-
let man = [
236
-
`S Manpage.s_description;
237
-
`P "Interactively creates a monopam.toml configuration file in the current \
238
-
directory. Prompts for the paths to the opam overlay, checkouts directory, \
239
-
and monorepo directory.";
240
-
`P "All paths must be absolute. You can use ~/ for your home directory, \
241
-
and relative paths will be converted to absolute based on the current \
242
-
working directory.";
243
-
] in
275
+
let man =
276
+
[
277
+
`S Manpage.s_description;
278
+
`P
279
+
"Interactively creates a monopam.toml configuration file in the \
280
+
current directory. Prompts for the paths to the opam overlay, \
281
+
checkouts directory, and monorepo directory.";
282
+
`P
283
+
"All paths must be absolute. You can use ~/ for your home directory, \
284
+
and relative paths will be converted to absolute based on the current \
285
+
working directory.";
286
+
]
287
+
in
244
288
let info = Cmd.info "init" ~doc ~man in
245
289
let output_arg =
246
290
let doc = "Output path for config file (default: monopam.toml)" in
247
-
Arg.(value & opt string "monopam.toml" & info [ "o"; "output" ] ~docv:"FILE" ~doc)
291
+
Arg.(
292
+
value & opt string "monopam.toml"
293
+
& info [ "o"; "output" ] ~docv:"FILE" ~doc)
248
294
in
249
295
let run output () =
250
296
Eio_main.run @@ fun env ->
251
297
let _fs = Eio.Stdenv.fs env in
252
298
let cwd_path = Eio.Stdenv.cwd env in
253
-
let stdin = Eio.Buf_read.of_flow ~max_size:(1024 * 1024) (Eio.Stdenv.stdin env) in
299
+
let stdin =
300
+
Eio.Buf_read.of_flow ~max_size:(1024 * 1024) (Eio.Stdenv.stdin env)
301
+
in
254
302
let stdout = Eio.Stdenv.stdout env in
255
303
(* Get current working directory as Fpath *)
256
304
let cwd =
257
-
let (_, cwd_str) = (cwd_path :> _ Eio.Path.t) in
258
-
match Fpath.of_string cwd_str with
259
-
| Ok p -> p
260
-
| Error _ -> Fpath.v "/"
305
+
let _, cwd_str = (cwd_path :> _ Eio.Path.t) in
306
+
match Fpath.of_string cwd_str with Ok p -> p | Error _ -> Fpath.v "/"
261
307
in
262
308
Eio.Flow.copy_string "Monopam Configuration Setup\n" stdout;
263
309
Eio.Flow.copy_string "===========================\n\n" stdout;
264
-
Eio.Flow.copy_string "All paths must be absolute. Use ~/ for home directory.\n" stdout;
265
-
Eio.Flow.copy_string "Relative paths will be converted to absolute.\n\n" stdout;
310
+
Eio.Flow.copy_string
311
+
"All paths must be absolute. Use ~/ for home directory.\n" stdout;
312
+
Eio.Flow.copy_string "Relative paths will be converted to absolute.\n\n"
313
+
stdout;
266
314
(* Prompt for opam_repo *)
267
315
let opam_repo = ref None in
268
316
while !opam_repo = None do
269
-
match prompt_path ~stdin ~stdout ~cwd "Path to opam overlay repository" ~default:None with
317
+
match
318
+
prompt_path ~stdin ~stdout ~cwd "Path to opam overlay repository"
319
+
~default:None
320
+
with
270
321
| Ok p -> opam_repo := Some p
271
322
| Error msg ->
272
-
Eio.Flow.copy_string (Fmt.str "Error: %s. Please try again.\n" msg) stdout
323
+
Eio.Flow.copy_string
324
+
(Fmt.str "Error: %s. Please try again.\n" msg)
325
+
stdout
273
326
done;
274
327
let opam_repo = Option.get !opam_repo in
275
328
(* Prompt for checkouts *)
276
329
let default_checkouts = Fpath.(parent opam_repo / "src") in
277
330
let checkouts = ref None in
278
331
while !checkouts = None do
279
-
match prompt_path ~stdin ~stdout ~cwd "Path for git checkouts" ~default:(Some default_checkouts) with
332
+
match
333
+
prompt_path ~stdin ~stdout ~cwd "Path for git checkouts"
334
+
~default:(Some default_checkouts)
335
+
with
280
336
| Ok p -> checkouts := Some p
281
337
| Error msg ->
282
-
Eio.Flow.copy_string (Fmt.str "Error: %s. Please try again.\n" msg) stdout
338
+
Eio.Flow.copy_string
339
+
(Fmt.str "Error: %s. Please try again.\n" msg)
340
+
stdout
283
341
done;
284
342
let checkouts = Option.get !checkouts in
285
343
(* Prompt for monorepo *)
286
344
let default_monorepo = Fpath.(parent opam_repo / "mono") in
287
345
let monorepo = ref None in
288
346
while !monorepo = None do
289
-
match prompt_path ~stdin ~stdout ~cwd "Path for monorepo" ~default:(Some default_monorepo) with
347
+
match
348
+
prompt_path ~stdin ~stdout ~cwd "Path for monorepo"
349
+
~default:(Some default_monorepo)
350
+
with
290
351
| Ok p -> monorepo := Some p
291
352
| Error msg ->
292
-
Eio.Flow.copy_string (Fmt.str "Error: %s. Please try again.\n" msg) stdout
353
+
Eio.Flow.copy_string
354
+
(Fmt.str "Error: %s. Please try again.\n" msg)
355
+
stdout
293
356
done;
294
357
let monorepo = Option.get !monorepo in
295
358
(* Prompt for default branch *)
···
297
360
let branch_input = String.trim (Eio.Buf_read.line stdin) in
298
361
let default_branch = if branch_input = "" then "main" else branch_input in
299
362
(* Create config *)
300
-
let config = Monopam.Config.create ~opam_repo ~checkouts ~monorepo ~default_branch () in
363
+
let config =
364
+
Monopam.Config.create ~opam_repo ~checkouts ~monorepo ~default_branch ()
365
+
in
301
366
(* Save config *)
302
367
let output_path = Fpath.v output in
303
-
match Monopam.Config.save ~fs:(cwd_path :> _ Eio.Path.t) config output_path with
368
+
match
369
+
Monopam.Config.save ~fs:(cwd_path :> _ Eio.Path.t) config output_path
370
+
with
304
371
| Ok () ->
305
-
Eio.Flow.copy_string (Fmt.str "\nConfiguration saved to %s\n" output) stdout;
306
-
Eio.Flow.copy_string "\nYou can now run 'monopam pull' to initialize the monorepo.\n" stdout;
372
+
Eio.Flow.copy_string
373
+
(Fmt.str "\nConfiguration saved to %s\n" output)
374
+
stdout;
375
+
Eio.Flow.copy_string
376
+
"\nYou can now run 'monopam pull' to initialize the monorepo.\n"
377
+
stdout;
307
378
`Ok ()
308
379
| Error msg ->
309
380
Fmt.epr "Error saving config: %s@." msg;
···
323
394
individual git checkouts, and a monorepo using git subtrees.";
324
395
`S "DIRECTORY STRUCTURE";
325
396
`P "Monopam manages three directory trees:";
326
-
`I ("opam-repo/", "The opam overlay repository containing package metadata. \
327
-
Each package's opam file specifies a dev-repo URL pointing to its git source.");
328
-
`I ("src/", "Individual git checkouts of each unique repository. Multiple \
329
-
packages may share a checkout if they come from the same dev-repo. \
330
-
Directory names are the repository basename (e.g., ocaml-yaml from \
331
-
https://github.com/foo/ocaml-yaml.git).");
332
-
`I ("mono/", "The monorepo combining all packages as git subtrees. Each \
333
-
subtree directory is named after the repository basename. This is \
334
-
where you make changes that span multiple packages.");
397
+
`I
398
+
( "opam-repo/",
399
+
"The opam overlay repository containing package metadata. Each \
400
+
package's opam file specifies a dev-repo URL pointing to its git \
401
+
source." );
402
+
`I
403
+
( "src/",
404
+
"Individual git checkouts of each unique repository. Multiple \
405
+
packages may share a checkout if they come from the same dev-repo. \
406
+
Directory names are the repository basename (e.g., ocaml-yaml from \
407
+
https://github.com/foo/ocaml-yaml.git)." );
408
+
`I
409
+
( "mono/",
410
+
"The monorepo combining all packages as git subtrees. Each subtree \
411
+
directory is named after the repository basename. This is where you \
412
+
make changes that span multiple packages." );
335
413
`S "WORKFLOW";
336
414
`P "The typical workflow is:";
337
-
`I ("1. monopam pull", "Fetch latest from all remotes, update checkouts, \
338
-
merge into monorepo subtrees");
415
+
`I
416
+
( "1. monopam pull",
417
+
"Fetch latest from all remotes, update checkouts, merge into \
418
+
monorepo subtrees" );
339
419
`I ("2. Edit code", "Make changes in the mono/ directory");
340
420
`I ("3. git commit", "Commit your changes in mono/");
341
421
`I ("4. monopam push", "Extract changes back to individual checkouts");
342
-
`I ("5. Review and push", "Review changes in src/*/, then git push each one");
422
+
`I
423
+
( "5. Review and push",
424
+
"Review changes in src/*/, then git push each one" );
343
425
`S "CONFIGURATION";
344
-
`P "Run $(b,monopam init) to interactively create a configuration file. \
345
-
Configuration is read from monopam.toml in the current directory \
346
-
or XDG config locations.";
426
+
`P
427
+
"Run $(b,monopam init) to interactively create a configuration file. \
428
+
Configuration is read from monopam.toml in the current directory or \
429
+
XDG config locations.";
347
430
`P "All paths in the configuration must be absolute. Example:";
348
-
`Pre "opam_repo = \"/home/user/opam-overlay\"\n\
349
-
checkouts = \"/home/user/src\"\n\
350
-
monorepo = \"/home/user/mono\"\n\
351
-
default_branch = \"main\"";
431
+
`Pre
432
+
"opam_repo = \"/home/user/opam-overlay\"\n\
433
+
checkouts = \"/home/user/src\"\n\
434
+
monorepo = \"/home/user/mono\"\n\
435
+
default_branch = \"main\"";
352
436
`S Manpage.s_commands;
353
437
`P "Use $(b,monopam COMMAND --help) for help on a specific command.";
354
438
]
+14
-17
lib/config.ml
+14
-17
lib/config.ml
···
50
50
Tomlt.map
51
51
~dec:(fun s ->
52
52
let s = expand_tilde s in
53
-
match Fpath.of_string s with
54
-
| Ok p -> p
55
-
| Error (`Msg m) -> failwith m)
53
+
match Fpath.of_string s with Ok p -> p | Error (`Msg m) -> failwith m)
56
54
~enc:Fpath.to_string Tomlt.string
57
55
58
56
let codec : t Tomlt.t =
59
57
Tomlt.(
60
58
Table.(
61
-
obj
62
-
(fun opam_repo checkouts monorepo default_branch packages ->
59
+
obj (fun opam_repo checkouts monorepo default_branch packages ->
63
60
{
64
61
opam_repo;
65
62
checkouts;
···
70
67
|> mem "opam_repo" fpath_codec ~enc:(fun c -> c.opam_repo)
71
68
|> mem "checkouts" fpath_codec ~enc:(fun c -> c.checkouts)
72
69
|> mem "monorepo" fpath_codec ~enc:(fun c -> c.monorepo)
73
-
|> opt_mem "default_branch" string
74
-
~enc:(fun c ->
75
-
if c.default_branch = "main" then None else Some c.default_branch)
70
+
|> opt_mem "default_branch" string ~enc:(fun c ->
71
+
if c.default_branch = "main" then None else Some c.default_branch)
76
72
|> keep_unknown
77
73
~enc:(fun c -> c.packages)
78
74
(Mems.assoc Package_config.codec)
···
92
88
Fmt.pf ppf "%s path is not a directory: %a" field Fpath.pp path
93
89
| Not_an_opam_repo path ->
94
90
Fmt.pf ppf
95
-
"opam_repo is not a valid opam repository (missing packages/ directory): %a"
91
+
"opam_repo is not a valid opam repository (missing packages/ \
92
+
directory): %a"
96
93
Fpath.pp path
97
-
| Invalid_path (field, msg) ->
98
-
Fmt.pf ppf "%s has invalid path: %s" field msg
94
+
| Invalid_path (field, msg) -> Fmt.pf ppf "%s has invalid path: %s" field msg
99
95
| Relative_path (field, path) ->
100
-
Fmt.pf ppf "%s must be an absolute path, got: %a\n\
101
-
Hint: Use an absolute path starting with / or ~/" field Fpath.pp path
96
+
Fmt.pf ppf
97
+
"%s must be an absolute path, got: %a\n\
98
+
Hint: Use an absolute path starting with / or ~/"
99
+
field Fpath.pp path
102
100
103
101
let validate ~fs t =
104
102
(* Get the root filesystem for checking absolute paths *)
105
103
let root_fs =
106
-
let (dir, _) = (fs : _ Eio.Path.t) in
104
+
let dir, _ = (fs : _ Eio.Path.t) in
107
105
(dir, "")
108
106
in
109
107
let check_absolute field path =
110
-
if Fpath.is_abs path then Ok ()
111
-
else Error (Relative_path (field, path))
108
+
if Fpath.is_abs path then Ok () else Error (Relative_path (field, path))
112
109
in
113
110
let check_dir field path =
114
111
let eio_path = Eio.Path.(root_fs / Fpath.to_string path) in
···
155
152
let config =
156
153
Tomlt_eio.decode_path_exn codec ~fs:config_dir (snd config_path)
157
154
in
158
-
let (dir, _) = config_dir in
155
+
let dir, _ = config_dir in
159
156
validate ~fs:(dir, "") config
160
157
|> Result.map_error (fun e -> Fmt.str "%a" pp_validation_error e)
161
158
with
+40
-41
lib/config.mli
+40
-41
lib/config.mli
···
1
1
(** Configuration management for monopam.
2
2
3
3
Configuration is stored in TOML format and loaded from XDG standard
4
-
locations or a user-specified path. The config file specifies paths
5
-
to the opam overlay, individual checkouts, and the monorepo, along
6
-
with optional per-package overrides. *)
4
+
locations or a user-specified path. The config file specifies paths to the
5
+
opam overlay, individual checkouts, and the monorepo, along with optional
6
+
per-package overrides. *)
7
7
8
8
(** {1 Types} *)
9
9
10
10
(** Per-package configuration overrides. *)
11
11
module Package_config : sig
12
-
(** Package-specific settings. *)
13
12
type t
13
+
(** Package-specific settings. *)
14
14
15
+
val branch : t -> string option
15
16
(** [branch t] returns the branch override for this package, if set. *)
16
-
val branch : t -> string option
17
17
end
18
18
19
+
type t
19
20
(** The main configuration. *)
20
-
type t
21
21
22
22
(** {1 Paths Configuration} *)
23
23
24
24
(** Path-related accessors. *)
25
25
module Paths : sig
26
-
(** [opam_repo t] returns the path to the opam overlay repository. *)
27
26
val opam_repo : t -> Fpath.t
27
+
(** [opam_repo t] returns the path to the opam overlay repository. *)
28
28
29
-
(** [checkouts t] returns the parent directory where individual
30
-
package checkouts are stored. *)
31
29
val checkouts : t -> Fpath.t
30
+
(** [checkouts t] returns the parent directory where individual package
31
+
checkouts are stored. *)
32
32
33
+
val monorepo : t -> Fpath.t
33
34
(** [monorepo t] returns the path to the monorepo directory. *)
34
-
val monorepo : t -> Fpath.t
35
35
end
36
36
37
37
(** {1 Options} *)
38
38
39
+
val default_branch : t -> string
39
40
(** [default_branch t] returns the default git branch to track.
40
41
41
42
Defaults to "main" if not specified. *)
42
-
val default_branch : t -> string
43
43
44
-
(** [package_config t name] returns package-specific configuration
45
-
overrides for the named package, if any exist. *)
46
44
val package_config : t -> string -> Package_config.t option
45
+
(** [package_config t name] returns package-specific configuration overrides for
46
+
the named package, if any exist. *)
47
47
48
48
(** {1 Validation} *)
49
49
50
50
(** Errors that can occur when validating configuration paths. *)
51
51
type validation_error =
52
-
| Path_not_found of string * Fpath.t
53
-
(** A configured path does not exist *)
52
+
| Path_not_found of string * Fpath.t (** A configured path does not exist *)
54
53
| Not_a_directory of string * Fpath.t
55
54
(** A configured path is not a directory *)
56
55
| Not_an_opam_repo of Fpath.t
57
-
(** The opam_repo path is not a valid opam repository
58
-
(missing packages/ directory) *)
59
-
| Invalid_path of string * string
60
-
(** A path string could not be parsed *)
56
+
(** The opam_repo path is not a valid opam repository (missing packages/
57
+
directory) *)
58
+
| Invalid_path of string * string (** A path string could not be parsed *)
61
59
| Relative_path of string * Fpath.t
62
60
(** A configured path is relative but must be absolute *)
63
61
64
-
(** [pp_validation_error] formats validation errors. *)
65
62
val pp_validation_error : validation_error Fmt.t
63
+
(** [pp_validation_error] formats validation errors. *)
66
64
67
65
(** {1 Loading and Saving} *)
68
66
67
+
val load :
68
+
fs:_ Eio.Path.t -> root_fs:_ Eio.Path.t -> Fpath.t -> (t, string) result
69
69
(** [load ~fs ~root_fs path] loads configuration from the specified TOML file.
70
70
71
-
Validates that paths exist and are valid. Supports tilde expansion
72
-
for paths (e.g., [~/src/...]).
71
+
Validates that paths exist and are valid. Supports tilde expansion for paths
72
+
(e.g., [~/src/...]).
73
73
74
74
@param fs The filesystem path for locating the config file
75
75
@param root_fs The root filesystem for validating absolute paths in config
76
76
77
-
Returns [Error msg] if the file cannot be read, parsed, or
78
-
if validation fails. *)
79
-
val load : fs:_ Eio.Path.t -> root_fs:_ Eio.Path.t -> Fpath.t -> (t, string) result
77
+
Returns [Error msg] if the file cannot be read, parsed, or if validation
78
+
fails. *)
80
79
80
+
val load_xdg : xdg:Xdge.t -> unit -> (t, string) result
81
81
(** [load_xdg ~xdg ()] loads configuration from XDG standard locations.
82
82
83
-
Searches for "config.toml" in the monopam XDG config directory.
84
-
Validates that paths exist and are valid. Supports tilde expansion.
83
+
Searches for "config.toml" in the monopam XDG config directory. Validates
84
+
that paths exist and are valid. Supports tilde expansion.
85
85
86
-
Returns [Error msg] if no config file is found, parsing fails, or
87
-
if validation fails.
86
+
Returns [Error msg] if no config file is found, parsing fails, or if
87
+
validation fails.
88
88
89
89
@param xdg The Xdge context for "monopam" application *)
90
-
val load_xdg : xdg:Xdge.t -> unit -> (t, string) result
91
90
92
-
(** [save ~fs t path] writes the configuration to the specified path. *)
93
91
val save : fs:_ Eio.Path.t -> t -> Fpath.t -> (unit, string) result
92
+
(** [save ~fs t path] writes the configuration to the specified path. *)
94
93
95
94
(** {1 Construction} *)
96
95
97
-
(** [create ~opam_repo ~checkouts ~monorepo ?default_branch ()] creates
98
-
a new configuration with the specified paths.
99
-
100
-
@param opam_repo Path to the opam overlay repository
101
-
@param checkouts Parent directory for individual git checkouts
102
-
@param monorepo Path to the monorepo
103
-
@param default_branch Default branch to track (default: "main") *)
104
96
val create :
105
97
opam_repo:Fpath.t ->
106
98
checkouts:Fpath.t ->
···
108
100
?default_branch:string ->
109
101
unit ->
110
102
t
103
+
(** [create ~opam_repo ~checkouts ~monorepo ?default_branch ()] creates a new
104
+
configuration with the specified paths.
111
105
112
-
(** [with_package_override t ~name ~branch] returns a new config with
113
-
a branch override for the named package. *)
106
+
@param opam_repo Path to the opam overlay repository
107
+
@param checkouts Parent directory for individual git checkouts
108
+
@param monorepo Path to the monorepo
109
+
@param default_branch Default branch to track (default: "main") *)
110
+
114
111
val with_package_override : t -> name:string -> branch:string -> t
112
+
(** [with_package_override t ~name ~branch] returns a new config with a branch
113
+
override for the named package. *)
115
114
116
115
(** {1 Pretty Printing} *)
117
116
118
-
(** [pp] is a formatter for configuration. *)
119
117
val pp : t Fmt.t
118
+
(** [pp] is a formatter for configuration. *)
+1
-10
lib/dune
+1
-10
lib/dune
+9
-5
lib/git.ml
+9
-5
lib/git.ml
···
52
52
else Error (Command_failed (String.concat " " ("git" :: args), result))
53
53
54
54
let path_to_eio ~(fs : Eio.Fs.dir_ty Eio.Path.t) path =
55
-
let (dir, _) = fs in
55
+
let dir, _ = fs in
56
56
(dir, Fpath.to_string path)
57
57
58
58
let is_repo ~proc ~fs path =
···
79
79
let cwd = Eio.Path.(fs / Fpath.to_string parent) in
80
80
let target_name = Fpath.basename target in
81
81
let url_str = Uri.to_string url in
82
-
run_git_ok ~proc ~cwd
83
-
[ "clone"; "--branch"; branch; url_str; target_name ]
82
+
run_git_ok ~proc ~cwd [ "clone"; "--branch"; branch; url_str; target_name ]
84
83
|> Result.map ignore
85
84
86
85
let fetch ~proc ~fs ?(remote = "origin") path =
···
115
114
let ahead_behind ~proc ~fs ?(remote = "origin") ?branch path =
116
115
let cwd = path_to_eio ~fs path in
117
116
let branch =
118
-
match branch with Some b -> b | None -> Option.value ~default:"HEAD" (current_branch ~proc ~fs path)
117
+
match branch with
118
+
| Some b -> b
119
+
| None -> Option.value ~default:"HEAD" (current_branch ~proc ~fs path)
119
120
in
120
121
let upstream = remote ^ "/" ^ branch in
121
-
match run_git_ok ~proc ~cwd [ "rev-list"; "--left-right"; "--count"; branch ^ "..." ^ upstream ] with
122
+
match
123
+
run_git_ok ~proc ~cwd
124
+
[ "rev-list"; "--left-right"; "--count"; branch ^ "..." ^ upstream ]
125
+
with
122
126
| Error e -> Error e
123
127
| Ok output -> (
124
128
match String.split_on_char '\t' output with
+71
-90
lib/git.mli
+71
-90
lib/git.mli
···
1
1
(** Git operations for monopam.
2
2
3
-
This module provides git operations needed for managing individual
4
-
checkouts and git subtree operations in the monorepo. All operations
5
-
use Eio for process spawning. *)
3
+
This module provides git operations needed for managing individual checkouts
4
+
and git subtree operations in the monorepo. All operations use Eio for
5
+
process spawning. *)
6
6
7
7
(** {1 Types} *)
8
8
9
+
type cmd_result = { exit_code : int; stdout : string; stderr : string }
9
10
(** Result of a git command execution. *)
10
-
type cmd_result = {
11
-
exit_code : int;
12
-
stdout : string;
13
-
stderr : string;
14
-
}
15
11
16
12
(** Errors from git operations. *)
17
13
type error =
18
14
| Command_failed of string * cmd_result
19
15
(** Git command failed: (command, result) *)
20
-
| Not_a_repo of Fpath.t
21
-
(** Path is not a git repository *)
22
-
| Dirty_worktree of Fpath.t
23
-
(** Repository has uncommitted changes *)
24
-
| Remote_not_found of string
25
-
(** Named remote does not exist *)
26
-
| Branch_not_found of string
27
-
(** Named branch does not exist *)
16
+
| Not_a_repo of Fpath.t (** Path is not a git repository *)
17
+
| Dirty_worktree of Fpath.t (** Repository has uncommitted changes *)
18
+
| Remote_not_found of string (** Named remote does not exist *)
19
+
| Branch_not_found of string (** Named branch does not exist *)
28
20
| Subtree_prefix_exists of string
29
21
(** Subtree prefix already exists in repo *)
30
-
| Subtree_prefix_missing of string
31
-
(** Subtree prefix does not exist *)
32
-
| Io_error of string
33
-
(** Filesystem or process error *)
22
+
| Subtree_prefix_missing of string (** Subtree prefix does not exist *)
23
+
| Io_error of string (** Filesystem or process error *)
34
24
35
-
(** [pp_error] is a formatter for errors. *)
36
25
val pp_error : error Fmt.t
26
+
(** [pp_error] is a formatter for errors. *)
37
27
38
28
(** {1 Repository Queries} *)
39
29
40
-
(** [is_repo ~proc ~fs path] returns true if path is a git repository. *)
41
30
val is_repo :
42
-
proc:_ Eio.Process.mgr ->
43
-
fs:Eio.Fs.dir_ty Eio.Path.t ->
44
-
Fpath.t ->
45
-
bool
31
+
proc:_ Eio.Process.mgr -> fs:Eio.Fs.dir_ty Eio.Path.t -> Fpath.t -> bool
32
+
(** [is_repo ~proc ~fs path] returns true if path is a git repository. *)
46
33
47
-
(** [is_dirty ~proc ~fs path] returns true if the repository has
48
-
uncommitted changes (staged or unstaged). *)
49
34
val is_dirty :
50
-
proc:_ Eio.Process.mgr ->
51
-
fs:Eio.Fs.dir_ty Eio.Path.t ->
52
-
Fpath.t ->
53
-
bool
35
+
proc:_ Eio.Process.mgr -> fs:Eio.Fs.dir_ty Eio.Path.t -> Fpath.t -> bool
36
+
(** [is_dirty ~proc ~fs path] returns true if the repository has uncommitted
37
+
changes (staged or unstaged). *)
54
38
55
-
(** [current_branch ~proc ~fs path] returns the current branch name,
56
-
or [None] if in detached HEAD state. *)
57
39
val current_branch :
58
40
proc:_ Eio.Process.mgr ->
59
41
fs:Eio.Fs.dir_ty Eio.Path.t ->
60
42
Fpath.t ->
61
43
string option
44
+
(** [current_branch ~proc ~fs path] returns the current branch name, or [None]
45
+
if in detached HEAD state. *)
62
46
63
-
(** [head_commit ~proc ~fs path] returns the current HEAD commit hash. *)
64
47
val head_commit :
65
48
proc:_ Eio.Process.mgr ->
66
49
fs:Eio.Fs.dir_ty Eio.Path.t ->
67
50
Fpath.t ->
68
51
(string, error) result
52
+
(** [head_commit ~proc ~fs path] returns the current HEAD commit hash. *)
69
53
70
54
(** {1 Basic Operations} *)
71
55
72
-
(** [clone ~proc ~fs ~url ~branch target] clones a repository.
73
-
74
-
@param proc Eio process manager
75
-
@param fs Eio filesystem
76
-
@param url Git remote URL
77
-
@param branch Branch to checkout
78
-
@param target Destination directory *)
79
56
val clone :
80
57
proc:_ Eio.Process.mgr ->
81
58
fs:Eio.Fs.dir_ty Eio.Path.t ->
···
83
60
branch:string ->
84
61
Fpath.t ->
85
62
(unit, error) result
63
+
(** [clone ~proc ~fs ~url ~branch target] clones a repository.
86
64
87
-
(** [fetch ~proc ~fs ?remote path] fetches from the remote.
65
+
@param proc Eio process manager
66
+
@param fs Eio filesystem
67
+
@param url Git remote URL
68
+
@param branch Branch to checkout
69
+
@param target Destination directory *)
88
70
89
-
@param remote Remote name (default: "origin") *)
90
71
val fetch :
91
72
proc:_ Eio.Process.mgr ->
92
73
fs:Eio.Fs.dir_ty Eio.Path.t ->
93
74
?remote:string ->
94
75
Fpath.t ->
95
76
(unit, error) result
77
+
(** [fetch ~proc ~fs ?remote path] fetches from the remote.
96
78
97
-
(** [merge_ff ~proc ~fs ?remote ?branch path] performs a fast-forward only
98
-
merge from the remote tracking branch.
79
+
@param remote Remote name (default: "origin") *)
99
80
100
-
@param remote Remote name (default: "origin")
101
-
@param branch Branch to merge from (default: current branch) *)
102
81
val merge_ff :
103
82
proc:_ Eio.Process.mgr ->
104
83
fs:Eio.Fs.dir_ty Eio.Path.t ->
···
106
85
?branch:string ->
107
86
Fpath.t ->
108
87
(unit, error) result
109
-
110
-
(** [pull ~proc ~fs ?remote ?branch path] pulls from the remote.
88
+
(** [merge_ff ~proc ~fs ?remote ?branch path] performs a fast-forward only merge
89
+
from the remote tracking branch.
111
90
112
91
@param remote Remote name (default: "origin")
113
-
@param branch Branch to pull (default: current branch) *)
92
+
@param branch Branch to merge from (default: current branch) *)
93
+
114
94
val pull :
115
95
proc:_ Eio.Process.mgr ->
116
96
fs:Eio.Fs.dir_ty Eio.Path.t ->
···
118
98
?branch:string ->
119
99
Fpath.t ->
120
100
(unit, error) result
101
+
(** [pull ~proc ~fs ?remote ?branch path] pulls from the remote.
121
102
122
-
(** [checkout ~proc ~fs ~branch path] checks out the specified branch. *)
103
+
@param remote Remote name (default: "origin")
104
+
@param branch Branch to pull (default: current branch) *)
105
+
123
106
val checkout :
124
107
proc:_ Eio.Process.mgr ->
125
108
fs:Eio.Fs.dir_ty Eio.Path.t ->
126
109
branch:string ->
127
110
Fpath.t ->
128
111
(unit, error) result
112
+
(** [checkout ~proc ~fs ~branch path] checks out the specified branch. *)
129
113
130
114
(** {1 Comparison} *)
131
115
132
-
(** Describes how a local branch relates to its upstream. *)
133
116
type ahead_behind = {
134
117
ahead : int; (** Commits ahead of upstream *)
135
118
behind : int; (** Commits behind upstream *)
136
119
}
137
-
138
-
(** [ahead_behind ~proc ~fs ?remote ?branch path] computes how many
139
-
commits the local branch is ahead/behind the remote.
120
+
(** Describes how a local branch relates to its upstream. *)
140
121
141
-
@param remote Remote name (default: "origin")
142
-
@param branch Branch to compare (default: current branch) *)
143
122
val ahead_behind :
144
123
proc:_ Eio.Process.mgr ->
145
124
fs:Eio.Fs.dir_ty Eio.Path.t ->
···
147
126
?branch:string ->
148
127
Fpath.t ->
149
128
(ahead_behind, error) result
129
+
(** [ahead_behind ~proc ~fs ?remote ?branch path] computes how many commits the
130
+
local branch is ahead/behind the remote.
131
+
132
+
@param remote Remote name (default: "origin")
133
+
@param branch Branch to compare (default: current branch) *)
150
134
151
135
(** {1 Subtree Operations} *)
152
136
153
137
(** Operations for git subtree management in the monorepo. *)
154
138
module Subtree : sig
155
-
(** [add ~proc ~fs ~repo ~prefix ~url ~branch ()] adds a new subtree
156
-
to the repository.
157
-
158
-
@param repo Path to the monorepo
159
-
@param prefix Subdirectory for the subtree
160
-
@param url Git remote URL for the subtree source
161
-
@param branch Branch to add *)
162
139
val add :
163
140
proc:_ Eio.Process.mgr ->
164
141
fs:Eio.Fs.dir_ty Eio.Path.t ->
···
168
145
branch:string ->
169
146
unit ->
170
147
(unit, error) result
171
-
172
-
(** [pull ~proc ~fs ~repo ~prefix ~url ~branch ()] pulls updates from
173
-
the remote into the subtree.
148
+
(** [add ~proc ~fs ~repo ~prefix ~url ~branch ()] adds a new subtree to the
149
+
repository.
174
150
175
151
@param repo Path to the monorepo
176
-
@param prefix Subdirectory of the subtree
177
-
@param url Git remote URL
178
-
@param branch Branch to pull *)
152
+
@param prefix Subdirectory for the subtree
153
+
@param url Git remote URL for the subtree source
154
+
@param branch Branch to add *)
155
+
179
156
val pull :
180
157
proc:_ Eio.Process.mgr ->
181
158
fs:Eio.Fs.dir_ty Eio.Path.t ->
···
185
162
branch:string ->
186
163
unit ->
187
164
(unit, error) result
188
-
189
-
(** [push ~proc ~fs ~repo ~prefix ~url ~branch ()] pushes subtree
190
-
changes to the remote.
191
-
192
-
This extracts commits that affected the subtree and pushes them
193
-
to the specified remote/branch.
165
+
(** [pull ~proc ~fs ~repo ~prefix ~url ~branch ()] pulls updates from the
166
+
remote into the subtree.
194
167
195
168
@param repo Path to the monorepo
196
169
@param prefix Subdirectory of the subtree
197
170
@param url Git remote URL
198
-
@param branch Branch to push to *)
171
+
@param branch Branch to pull *)
172
+
199
173
val push :
200
174
proc:_ Eio.Process.mgr ->
201
175
fs:Eio.Fs.dir_ty Eio.Path.t ->
···
205
179
branch:string ->
206
180
unit ->
207
181
(unit, error) result
182
+
(** [push ~proc ~fs ~repo ~prefix ~url ~branch ()] pushes subtree changes to
183
+
the remote.
208
184
209
-
(** [split ~proc ~fs ~repo ~prefix ()] extracts commits for a subtree
210
-
into a standalone branch.
185
+
This extracts commits that affected the subtree and pushes them to the
186
+
specified remote/branch.
211
187
212
-
Returns the commit hash of the split branch head. *)
188
+
@param repo Path to the monorepo
189
+
@param prefix Subdirectory of the subtree
190
+
@param url Git remote URL
191
+
@param branch Branch to push to *)
192
+
213
193
val split :
214
194
proc:_ Eio.Process.mgr ->
215
195
fs:Eio.Fs.dir_ty Eio.Path.t ->
···
217
197
prefix:string ->
218
198
unit ->
219
199
(string, error) result
200
+
(** [split ~proc ~fs ~repo ~prefix ()] extracts commits for a subtree into a
201
+
standalone branch.
220
202
221
-
(** [exists ~fs ~repo ~prefix] returns true if the subtree prefix
222
-
directory exists in the repository. *)
203
+
Returns the commit hash of the split branch head. *)
204
+
223
205
val exists :
224
-
fs:Eio.Fs.dir_ty Eio.Path.t ->
225
-
repo:Fpath.t ->
226
-
prefix:string ->
227
-
bool
206
+
fs:Eio.Fs.dir_ty Eio.Path.t -> repo:Fpath.t -> prefix:string -> bool
207
+
(** [exists ~fs ~repo ~prefix] returns true if the subtree prefix directory
208
+
exists in the repository. *)
228
209
end
229
210
230
211
(** {1 Initialization} *)
231
212
232
-
(** [init ~proc ~fs path] initializes a new git repository. *)
233
213
val init :
234
214
proc:_ Eio.Process.mgr ->
235
215
fs:Eio.Fs.dir_ty Eio.Path.t ->
236
216
Fpath.t ->
237
217
(unit, error) result
218
+
(** [init ~proc ~fs path] initializes a new git repository. *)
238
219
239
-
(** [commit_allow_empty ~proc ~fs ~message path] creates a commit,
240
-
even if there are no changes. Useful for initializing a repository. *)
241
220
val commit_allow_empty :
242
221
proc:_ Eio.Process.mgr ->
243
222
fs:Eio.Fs.dir_ty Eio.Path.t ->
244
223
message:string ->
245
224
Fpath.t ->
246
225
(unit, error) result
226
+
(** [commit_allow_empty ~proc ~fs ~message path] creates a commit, even if there
227
+
are no changes. Useful for initializing a repository. *)
+297
-228
lib/monopam.ml
+297
-228
lib/monopam.ml
···
5
5
module Status = Status
6
6
7
7
let src = Logs.Src.create "monopam" ~doc:"Monopam operations"
8
+
8
9
module Log = (val Logs.src_log src : Logs.LOG)
9
10
10
11
type error =
···
25
26
| Package_not_found name -> Fmt.pf ppf "Package not found: %s" name
26
27
27
28
let fs_typed (fs : _ Eio.Path.t) : Eio.Fs.dir_ty Eio.Path.t =
28
-
let (dir, _) = fs in
29
+
let dir, _ = fs in
29
30
(dir, "")
30
31
31
32
let discover_packages ~fs ~config () =
32
33
let repo_path = Config.Paths.opam_repo config in
33
34
Log.debug (fun m -> m "Scanning opam repo at %a" Fpath.pp repo_path);
34
-
match Opam_repo.scan ~fs repo_path with
35
-
| Ok pkgs ->
35
+
Opam_repo.scan ~fs repo_path
36
+
|> Result.map_error (fun e -> Repo_error e)
37
+
|> Result.map (fun pkgs ->
36
38
Log.info (fun m -> m "Found %d packages in opam repo" (List.length pkgs));
37
-
Ok pkgs
38
-
| Error e -> Error (Repo_error e)
39
+
pkgs)
39
40
40
41
let find_package ~fs ~config name =
41
-
match discover_packages ~fs ~config () with
42
-
| Error e -> Error e
43
-
| Ok pkgs -> (
44
-
match List.find_opt (fun p -> Package.name p = name) pkgs with
45
-
| Some p -> Ok p
46
-
| None -> Error (Package_not_found name))
42
+
Result.bind (discover_packages ~fs ~config ()) (fun pkgs ->
43
+
List.find_opt (fun p -> Package.name p = name) pkgs
44
+
|> Option.to_result ~none:(Package_not_found name))
47
45
48
46
let rec mkdirs path =
49
47
match Eio.Path.kind ~follow:true path with
···
55
53
(* Parent might not exist, try to create it first *)
56
54
let parent = Eio.Path.split path in
57
55
(match parent with
58
-
| Some (parent_path, _) -> mkdirs parent_path
59
-
| None -> ());
56
+
| Some (parent_path, _) -> mkdirs parent_path
57
+
| None -> ());
60
58
Log.debug (fun m -> m "Creating directory %a" Eio.Path.pp path);
61
59
Eio.Path.mkdir ~perm:0o755 path
62
60
63
61
let ensure_checkouts_dir ~fs ~config =
64
62
let checkouts = Config.Paths.checkouts config in
65
63
let checkouts_eio = Eio.Path.(fs / Fpath.to_string checkouts) in
66
-
Log.debug (fun m -> m "Ensuring checkouts directory exists: %a" Fpath.pp checkouts);
64
+
Log.debug (fun m ->
65
+
m "Ensuring checkouts directory exists: %a" Fpath.pp checkouts);
67
66
mkdirs checkouts_eio
68
67
69
68
let status ~proc ~fs ~config () =
70
69
let fs = fs_typed fs in
71
-
(* Ensure checkouts directory exists before computing status *)
72
70
ensure_checkouts_dir ~fs ~config;
73
-
match discover_packages ~fs:(fs :> _ Eio.Path.t) ~config () with
74
-
| Error e -> Error e
75
-
| Ok pkgs -> Ok (Status.compute_all ~proc ~fs ~config pkgs)
71
+
discover_packages ~fs:(fs :> _ Eio.Path.t) ~config ()
72
+
|> Result.map (Status.compute_all ~proc ~fs ~config)
76
73
77
74
let get_branch ~config pkg =
75
+
let default = Config.default_branch config in
78
76
match Package.branch pkg with
79
77
| Some b -> b
80
-
| None -> (
81
-
match Config.package_config config (Package.name pkg) with
82
-
| Some pc -> Option.value ~default:(Config.default_branch config) (Config.Package_config.branch pc)
83
-
| None -> Config.default_branch config)
78
+
| None ->
79
+
Option.bind
80
+
(Config.package_config config (Package.name pkg))
81
+
Config.Package_config.branch
82
+
|> Option.value ~default
84
83
85
84
let ensure_checkout ~proc ~fs ~config pkg =
86
85
let checkouts_root = Config.Paths.checkouts config in
···
88
87
let checkout_eio = Eio.Path.(fs / Fpath.to_string checkout_dir) in
89
88
let branch = get_branch ~config pkg in
90
89
let do_clone () =
91
-
Log.info (fun m -> m "Cloning %s from %a (branch: %s)"
92
-
(Package.repo_name pkg) Uri.pp (Package.dev_repo pkg) branch);
90
+
Log.info (fun m ->
91
+
m "Cloning %s from %a (branch: %s)" (Package.repo_name pkg) Uri.pp
92
+
(Package.dev_repo pkg) branch);
93
93
Git.clone ~proc ~fs ~url:(Package.dev_repo pkg) ~branch checkout_dir
94
94
in
95
95
let is_directory =
···
112
112
(* Group packages by their repository *)
113
113
let group_by_repo pkgs =
114
114
let tbl = Hashtbl.create 16 in
115
-
List.iter (fun pkg ->
116
-
let repo = Package.repo_name pkg in
117
-
let existing = try Hashtbl.find tbl repo with Not_found -> [] in
118
-
Hashtbl.replace tbl repo (pkg :: existing)
119
-
) pkgs;
115
+
List.iter
116
+
(fun pkg ->
117
+
let repo = Package.repo_name pkg in
118
+
let existing = try Hashtbl.find tbl repo with Not_found -> [] in
119
+
Hashtbl.replace tbl repo (pkg :: existing))
120
+
pkgs;
120
121
(* Sort repos alphabetically and packages within each repo *)
121
-
Hashtbl.fold (fun repo pkgs acc -> (repo, List.sort Package.compare pkgs) :: acc) tbl []
122
+
Hashtbl.fold
123
+
(fun repo pkgs acc -> (repo, List.sort Package.compare pkgs) :: acc)
124
+
tbl []
122
125
|> List.sort (fun (a, _) (b, _) -> String.compare a b)
123
126
124
127
(* Generate README.md content from discovered packages *)
···
126
129
let grouped = group_by_repo pkgs in
127
130
let buf = Buffer.create 4096 in
128
131
Buffer.add_string buf "# Monorepo Package Index\n\n";
129
-
Buffer.add_string buf "This monorepo contains the following packages, synchronized from their upstream repositories.\n\n";
132
+
Buffer.add_string buf
133
+
"This monorepo contains the following packages, synchronized from their \
134
+
upstream repositories.\n\n";
130
135
Buffer.add_string buf "| Repository | Package | Version | Upstream |\n";
131
136
Buffer.add_string buf "|------------|---------|---------|----------|\n";
132
-
List.iter (fun (repo, pkgs) ->
133
-
List.iteri (fun i pkg ->
134
-
let repo_cell = if i = 0 then Printf.sprintf "**%s**" repo else "" in
135
-
let dev_repo = Uri.to_string (Package.dev_repo pkg) in
136
-
(* Clean up git+ prefix for display *)
137
-
let display_url =
138
-
if String.length dev_repo > 4 && String.sub dev_repo 0 4 = "git+" then
139
-
String.sub dev_repo 4 (String.length dev_repo - 4)
140
-
else dev_repo
141
-
in
142
-
Buffer.add_string buf (Printf.sprintf "| %s | %s | %s | %s |\n"
143
-
repo_cell (Package.name pkg) (Package.version pkg) display_url)
144
-
) pkgs
145
-
) grouped;
137
+
List.iter
138
+
(fun (repo, pkgs) ->
139
+
List.iteri
140
+
(fun i pkg ->
141
+
let repo_cell = if i = 0 then Printf.sprintf "**%s**" repo else "" in
142
+
let dev_repo = Uri.to_string (Package.dev_repo pkg) in
143
+
(* Clean up git+ prefix for display *)
144
+
let display_url =
145
+
if String.starts_with ~prefix:"git+" dev_repo then
146
+
String.sub dev_repo 4 (String.length dev_repo - 4)
147
+
else dev_repo
148
+
in
149
+
Buffer.add_string buf
150
+
(Printf.sprintf "| %s | %s | %s | %s |\n" repo_cell
151
+
(Package.name pkg) (Package.version pkg) display_url))
152
+
pkgs)
153
+
grouped;
146
154
Buffer.add_string buf "\n---\n\n";
147
-
Buffer.add_string buf (Printf.sprintf "_Generated by monopam. %d packages from %d repositories._\n"
148
-
(List.length pkgs) (List.length grouped));
155
+
Buffer.add_string buf
156
+
(Printf.sprintf
157
+
"_Generated by monopam. %d packages from %d repositories._\n"
158
+
(List.length pkgs) (List.length grouped));
149
159
Buffer.contents buf
150
160
151
-
let claude_md_content = {|# Monorepo Development Guide
161
+
let claude_md_content =
162
+
{|# Monorepo Development Guide
152
163
153
164
This is a monorepo managed by `monopam`. Each subdirectory is a git subtree
154
165
from a separate upstream repository.
···
215
226
Log.info (fun m -> m "Initializing monorepo at %a" Fpath.pp monorepo);
216
227
match Git.init ~proc ~fs monorepo with
217
228
| Error e -> Error (Git_error e)
218
-
| Ok () ->
229
+
| Ok () -> (
219
230
(* Create dune-project file so the monorepo builds *)
220
231
let dune_project = Eio.Path.(monorepo_eio / "dune-project") in
221
232
Log.debug (fun m -> m "Creating dune-project file");
222
-
Eio.Path.save ~create:(`Or_truncate 0o644) dune_project "(lang dune 3.20)\n";
233
+
Eio.Path.save ~create:(`Or_truncate 0o644) dune_project
234
+
"(lang dune 3.20)\n";
223
235
(* Create CLAUDE.md for agent instructions *)
224
236
let claude_md = Eio.Path.(monorepo_eio / "CLAUDE.md") in
225
237
Log.debug (fun m -> m "Creating CLAUDE.md");
···
231
243
(* Stage the files *)
232
244
Log.debug (fun m -> m "Staging initial files");
233
245
Eio.Switch.run (fun sw ->
234
-
let child = Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
235
-
[ "git"; "add"; "dune-project"; "CLAUDE.md"; ".gitignore" ] in
236
-
ignore (Eio.Process.await child));
246
+
let child =
247
+
Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
248
+
[ "git"; "add"; "dune-project"; "CLAUDE.md"; ".gitignore" ]
249
+
in
250
+
ignore (Eio.Process.await child));
237
251
(* Commit *)
238
252
Log.debug (fun m -> m "Creating initial commit in monorepo");
239
-
match Git.commit_allow_empty ~proc ~fs ~message:"Initial commit with dune-project, CLAUDE.md, and .gitignore" monorepo with
253
+
match
254
+
Git.commit_allow_empty ~proc ~fs
255
+
~message:
256
+
"Initial commit with dune-project, CLAUDE.md, and .gitignore"
257
+
monorepo
258
+
with
240
259
| Ok () -> Ok ()
241
-
| Error e -> Error (Git_error e)
260
+
| Error e -> Error (Git_error e))
242
261
in
243
-
let ensure_claude_md () =
244
-
let claude_md = Eio.Path.(monorepo_eio / "CLAUDE.md") in
262
+
let ensure_file ~filename ~content =
263
+
let file_path = Eio.Path.(monorepo_eio / filename) in
245
264
let exists =
246
-
match Eio.Path.kind ~follow:true claude_md with
265
+
match Eio.Path.kind ~follow:true file_path with
247
266
| `Regular_file -> true
248
-
| _ -> false
249
-
| exception Eio.Io _ -> false
267
+
| _ | (exception Eio.Io _) -> false
250
268
in
251
269
if not exists then begin
252
-
Log.info (fun m -> m "Adding CLAUDE.md to monorepo");
253
-
Eio.Path.save ~create:(`Or_truncate 0o644) claude_md claude_md_content;
270
+
Log.info (fun m -> m "Adding %s to monorepo" filename);
271
+
Eio.Path.save ~create:(`Or_truncate 0o644) file_path content;
254
272
Eio.Switch.run (fun sw ->
255
-
let child = Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
256
-
[ "git"; "add"; "CLAUDE.md" ] in
257
-
ignore (Eio.Process.await child));
258
-
Eio.Switch.run (fun sw ->
259
-
let child = Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
260
-
[ "git"; "commit"; "-m"; "Add CLAUDE.md" ] in
261
-
ignore (Eio.Process.await child))
262
-
end
263
-
in
264
-
let ensure_gitignore () =
265
-
let gitignore = Eio.Path.(monorepo_eio / ".gitignore") in
266
-
let exists =
267
-
match Eio.Path.kind ~follow:true gitignore with
268
-
| `Regular_file -> true
269
-
| _ -> false
270
-
| exception Eio.Io _ -> false
271
-
in
272
-
if not exists then begin
273
-
Log.info (fun m -> m "Adding .gitignore to monorepo");
274
-
Eio.Path.save ~create:(`Or_truncate 0o644) gitignore gitignore_content;
275
-
Eio.Switch.run (fun sw ->
276
-
let child = Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
277
-
[ "git"; "add"; ".gitignore" ] in
278
-
ignore (Eio.Process.await child));
273
+
let child =
274
+
Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
275
+
[ "git"; "add"; filename ]
276
+
in
277
+
ignore (Eio.Process.await child));
279
278
Eio.Switch.run (fun sw ->
280
-
let child = Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
281
-
[ "git"; "commit"; "-m"; "Add .gitignore" ] in
282
-
ignore (Eio.Process.await child))
279
+
let child =
280
+
Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
281
+
[ "git"; "commit"; "-m"; "Add " ^ filename ]
282
+
in
283
+
ignore (Eio.Process.await child))
283
284
end
284
285
in
285
286
let is_directory =
···
289
290
| exception Eio.Io _ -> false
290
291
in
291
292
if is_directory && Git.is_repo ~proc ~fs monorepo then begin
292
-
Log.debug (fun m -> m "Monorepo already initialized at %a" Fpath.pp monorepo);
293
-
ensure_claude_md ();
294
-
ensure_gitignore ();
293
+
Log.debug (fun m ->
294
+
m "Monorepo already initialized at %a" Fpath.pp monorepo);
295
+
ensure_file ~filename:"CLAUDE.md" ~content:claude_md_content;
296
+
ensure_file ~filename:".gitignore" ~content:gitignore_content;
295
297
Ok ()
296
-
end else begin
298
+
end
299
+
else begin
297
300
if not is_directory then begin
298
301
Log.debug (fun m -> m "Creating monorepo directory %a" Fpath.pp monorepo);
299
302
mkdirs monorepo_eio
···
318
321
Eio.Path.save ~create:(`Or_truncate 0o644) readme_path content;
319
322
(* Stage and commit the README *)
320
323
Eio.Switch.run (fun sw ->
321
-
let child = Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
322
-
[ "git"; "add"; "README.md" ] in
323
-
ignore (Eio.Process.await child));
324
+
let child =
325
+
Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
326
+
[ "git"; "add"; "README.md" ]
327
+
in
328
+
ignore (Eio.Process.await child));
324
329
Eio.Switch.run (fun sw ->
325
-
let child = Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
326
-
[ "git"; "commit"; "-m"; "Update README.md package index" ] in
327
-
ignore (Eio.Process.await child));
330
+
let child =
331
+
Eio.Process.spawn proc ~sw ~cwd:monorepo_eio
332
+
[ "git"; "commit"; "-m"; "Update README.md package index" ]
333
+
in
334
+
ignore (Eio.Process.await child));
328
335
Log.app (fun m -> m "Updated README.md with %d packages" (List.length pkgs))
329
336
end
330
337
···
344
351
(* Deduplicate packages by dev-repo, keeping first occurrence of each repo *)
345
352
let unique_repos pkgs =
346
353
let seen = Hashtbl.create 16 in
347
-
List.filter (fun pkg ->
348
-
let url = normalize_url_for_comparison (Package.dev_repo pkg) in
349
-
Log.debug (fun m -> m "Checking repo URL: %s (from %s)" url (Package.name pkg));
350
-
if Hashtbl.mem seen url then begin
351
-
Log.debug (fun m -> m " -> Already seen, skipping");
352
-
false
353
-
end else begin
354
-
Hashtbl.add seen url ();
355
-
Log.debug (fun m -> m " -> New repo, keeping");
356
-
true
357
-
end) pkgs
354
+
List.filter
355
+
(fun pkg ->
356
+
let url = normalize_url_for_comparison (Package.dev_repo pkg) in
357
+
Log.debug (fun m ->
358
+
m "Checking repo URL: %s (from %s)" url (Package.name pkg));
359
+
if Hashtbl.mem seen url then begin
360
+
Log.debug (fun m -> m " -> Already seen, skipping");
361
+
false
362
+
end
363
+
else begin
364
+
Hashtbl.add seen url ();
365
+
Log.debug (fun m -> m " -> New repo, keeping");
366
+
true
367
+
end)
368
+
pkgs
358
369
359
370
(* Result of pulling a single repo *)
360
371
type pull_result = {
361
372
repo_name : string;
362
-
cloned : bool; (* true if newly cloned, false if fetched *)
373
+
cloned : bool; (* true if newly cloned, false if fetched *)
363
374
commits_pulled : int; (* number of commits pulled, 0 if none or cloned *)
364
375
subtree_added : bool; (* true if subtree was newly added *)
365
376
}
···
375
386
match Git.Subtree.pull ~proc ~fs ~repo:monorepo ~prefix ~url ~branch () with
376
387
| Ok () -> Ok false (* not newly added *)
377
388
| Error e -> Error (Git_error e)
378
-
end else begin
389
+
end
390
+
else begin
379
391
Log.info (fun m -> m "Adding subtree %s" prefix);
380
392
match Git.Subtree.add ~proc ~fs ~repo:monorepo ~prefix ~url ~branch () with
381
393
| Ok () -> Ok true (* newly added *)
···
414
426
in
415
427
match result with
416
428
| Ok () -> ()
417
-
| Error e -> Log.warn (fun m -> m "Failed to update opam repo: %a" Git.pp_error e)
429
+
| Error e ->
430
+
Log.warn (fun m -> m "Failed to update opam repo: %a" Git.pp_error e)
418
431
end;
419
432
(* Ensure directories exist before computing status *)
420
433
ensure_checkouts_dir ~fs:fs_t ~config;
421
434
match ensure_monorepo_initialized ~proc ~fs:fs_t ~config with
422
435
| Error e -> Error e
423
-
| Ok () ->
424
-
match discover_packages ~fs:(fs_t :> _ Eio.Path.t) ~config () with
425
-
| Error e -> Error e
426
-
| Ok all_pkgs ->
427
-
let pkgs =
428
-
match package with
429
-
| None -> all_pkgs
430
-
| Some name -> List.filter (fun p -> Package.name p = name) all_pkgs
431
-
in
432
-
if pkgs = [] && package <> None then
433
-
Error (Package_not_found (Option.get package))
434
-
else begin
435
-
Log.info (fun m -> m "Checking status of %d packages" (List.length pkgs));
436
-
let statuses = Status.compute_all ~proc ~fs:fs_t ~config pkgs in
437
-
let dirty =
438
-
List.filter Status.has_local_changes statuses
439
-
|> List.map (fun s -> s.Status.package)
440
-
in
441
-
if dirty <> [] then Error (Dirty_state dirty)
442
-
else begin
443
-
(* First, clone/fetch unique repositories *)
444
-
let repos = unique_repos pkgs in
445
-
Log.info (fun m -> m "Cloning/fetching %d unique repositories" (List.length repos));
446
-
let clone_repos () =
447
-
let total = List.length repos in
448
-
let rec loop i acc = function
449
-
| [] -> Ok (List.rev acc)
450
-
| pkg :: rest ->
451
-
let repo_name = Package.repo_name pkg in
452
-
Log.info (fun m -> m "[%d/%d] Fetching repo %s" i total repo_name);
453
-
let existed = checkout_exists ~proc ~fs:fs_t ~config pkg in
454
-
let behind_before =
455
-
if existed then get_behind ~proc ~fs:fs_t ~config pkg else 0
456
-
in
457
-
match ensure_checkout ~proc ~fs:fs_t ~config pkg with
458
-
| Error e -> Error (Git_error e)
459
-
| Ok () ->
460
-
let result = {
461
-
repo_name;
462
-
cloned = not existed;
463
-
commits_pulled = behind_before;
464
-
subtree_added = false; (* will be updated later *)
465
-
} in
466
-
loop (i + 1) (result :: acc) rest
436
+
| Ok () -> (
437
+
match discover_packages ~fs:(fs_t :> _ Eio.Path.t) ~config () with
438
+
| Error e -> Error e
439
+
| Ok all_pkgs ->
440
+
let pkgs =
441
+
match package with
442
+
| None -> all_pkgs
443
+
| Some name -> List.filter (fun p -> Package.name p = name) all_pkgs
444
+
in
445
+
if pkgs = [] && package <> None then
446
+
Error (Package_not_found (Option.get package))
447
+
else begin
448
+
Log.info (fun m ->
449
+
m "Checking status of %d packages" (List.length pkgs));
450
+
let statuses = Status.compute_all ~proc ~fs:fs_t ~config pkgs in
451
+
let dirty =
452
+
List.filter Status.has_local_changes statuses
453
+
|> List.map (fun s -> s.Status.package)
467
454
in
468
-
loop 1 [] repos
469
-
in
470
-
match clone_repos () with
471
-
| Error e -> Error e
472
-
| Ok checkout_results ->
473
-
(* Then, add/pull subtrees for unique repos only *)
474
-
Log.info (fun m -> m "Processing %d unique subtrees" (List.length repos));
475
-
let total = List.length repos in
476
-
let rec loop i results_acc repos_left checkout_results_left =
477
-
match repos_left, checkout_results_left with
478
-
| [], [] -> Ok (List.rev results_acc)
479
-
| pkg :: rest_repos, cr :: rest_cr ->
480
-
Log.info (fun m -> m "[%d/%d] Subtree %s" i total (Package.subtree_prefix pkg));
481
-
(match pull_subtree ~proc ~fs ~config pkg with
482
-
| Ok subtree_added ->
483
-
let result = { cr with subtree_added } in
484
-
loop (i + 1) (result :: results_acc) rest_repos rest_cr
485
-
| Error e -> Error e)
486
-
| _ -> Ok (List.rev results_acc) (* mismatched lengths, shouldn't happen *)
455
+
if dirty <> [] then Error (Dirty_state dirty)
456
+
else begin
457
+
(* First, clone/fetch unique repositories *)
458
+
let repos = unique_repos pkgs in
459
+
Log.info (fun m ->
460
+
m "Cloning/fetching %d unique repositories"
461
+
(List.length repos));
462
+
let clone_repos () =
463
+
let total = List.length repos in
464
+
let rec loop i acc = function
465
+
| [] -> Ok (List.rev acc)
466
+
| pkg :: rest -> (
467
+
let repo_name = Package.repo_name pkg in
468
+
Log.info (fun m ->
469
+
m "[%d/%d] Fetching repo %s" i total repo_name);
470
+
let existed =
471
+
checkout_exists ~proc ~fs:fs_t ~config pkg
472
+
in
473
+
let behind_before =
474
+
if existed then get_behind ~proc ~fs:fs_t ~config pkg
475
+
else 0
476
+
in
477
+
match ensure_checkout ~proc ~fs:fs_t ~config pkg with
478
+
| Error e -> Error (Git_error e)
479
+
| Ok () ->
480
+
let result =
481
+
{
482
+
repo_name;
483
+
cloned = not existed;
484
+
commits_pulled = behind_before;
485
+
subtree_added = false;
486
+
(* will be updated later *)
487
+
}
488
+
in
489
+
loop (i + 1) (result :: acc) rest)
490
+
in
491
+
loop 1 [] repos
487
492
in
488
-
match loop 1 [] repos checkout_results with
493
+
match clone_repos () with
489
494
| Error e -> Error e
490
-
| Ok results ->
491
-
(* Print summary *)
492
-
let cloned = List.filter (fun r -> r.cloned) results in
493
-
let updated = List.filter (fun r -> not r.cloned && r.commits_pulled > 0) results in
494
-
let added = List.filter (fun r -> r.subtree_added) results in
495
-
if cloned <> [] then begin
496
-
Log.app (fun m -> m "Cloned %d new repositories:" (List.length cloned));
497
-
List.iter (fun r -> Log.app (fun m -> m " + %s" r.repo_name)) cloned
498
-
end;
499
-
if updated <> [] then begin
500
-
Log.app (fun m -> m "Updated %d repositories:" (List.length updated));
501
-
List.iter (fun r ->
502
-
Log.app (fun m -> m " ~ %s (%d new commits)" r.repo_name r.commits_pulled)
503
-
) updated
504
-
end;
505
-
if added <> [] then begin
506
-
Log.app (fun m -> m "Added %d new subtrees:" (List.length added));
507
-
List.iter (fun r -> Log.app (fun m -> m " + %s" r.repo_name)) added
508
-
end;
509
-
let unchanged = List.length results - List.length cloned - List.length updated in
510
-
if cloned = [] && updated = [] && added = [] then
511
-
Log.app (fun m -> m "All %d repositories up to date." (List.length results))
512
-
else if unchanged > 0 then
513
-
Log.app (fun m -> m "%d repositories unchanged." unchanged);
514
-
(* Update README.md with package summary *)
515
-
write_readme ~proc ~fs:fs_t ~config all_pkgs;
516
-
Ok ()
517
-
end
518
-
end
495
+
| Ok checkout_results -> (
496
+
(* Then, add/pull subtrees for unique repos only *)
497
+
Log.info (fun m ->
498
+
m "Processing %d unique subtrees" (List.length repos));
499
+
let total = List.length repos in
500
+
let rec loop i results_acc repos_left checkout_results_left =
501
+
match (repos_left, checkout_results_left) with
502
+
| [], [] -> Ok (List.rev results_acc)
503
+
| pkg :: rest_repos, cr :: rest_cr -> (
504
+
Log.info (fun m ->
505
+
m "[%d/%d] Subtree %s" i total
506
+
(Package.subtree_prefix pkg));
507
+
match pull_subtree ~proc ~fs ~config pkg with
508
+
| Ok subtree_added ->
509
+
let result = { cr with subtree_added } in
510
+
loop (i + 1) (result :: results_acc) rest_repos
511
+
rest_cr
512
+
| Error e -> Error e)
513
+
| _ -> Ok (List.rev results_acc)
514
+
(* mismatched lengths, shouldn't happen *)
515
+
in
516
+
match loop 1 [] repos checkout_results with
517
+
| Error e -> Error e
518
+
| Ok results ->
519
+
(* Print summary *)
520
+
let cloned = List.filter (fun r -> r.cloned) results in
521
+
let updated =
522
+
List.filter
523
+
(fun r -> (not r.cloned) && r.commits_pulled > 0)
524
+
results
525
+
in
526
+
let added =
527
+
List.filter (fun r -> r.subtree_added) results
528
+
in
529
+
if cloned <> [] then begin
530
+
Log.app (fun m ->
531
+
m "Cloned %d new repositories:" (List.length cloned));
532
+
List.iter
533
+
(fun r -> Log.app (fun m -> m " + %s" r.repo_name))
534
+
cloned
535
+
end;
536
+
if updated <> [] then begin
537
+
Log.app (fun m ->
538
+
m "Updated %d repositories:" (List.length updated));
539
+
List.iter
540
+
(fun r ->
541
+
Log.app (fun m ->
542
+
m " ~ %s (%d new commits)" r.repo_name
543
+
r.commits_pulled))
544
+
updated
545
+
end;
546
+
if added <> [] then begin
547
+
Log.app (fun m ->
548
+
m "Added %d new subtrees:" (List.length added));
549
+
List.iter
550
+
(fun r -> Log.app (fun m -> m " + %s" r.repo_name))
551
+
added
552
+
end;
553
+
let unchanged =
554
+
List.length results - List.length cloned
555
+
- List.length updated
556
+
in
557
+
if cloned = [] && updated = [] && added = [] then
558
+
Log.app (fun m ->
559
+
m "All %d repositories up to date."
560
+
(List.length results))
561
+
else if unchanged > 0 then
562
+
Log.app (fun m ->
563
+
m "%d repositories unchanged." unchanged);
564
+
(* Update README.md with package summary *)
565
+
write_readme ~proc ~fs:fs_t ~config all_pkgs;
566
+
Ok ())
567
+
end
568
+
end)
519
569
520
570
let run_git_in ~proc ~cwd args =
521
571
Eio.Switch.run @@ fun sw ->
···
530
580
match Eio.Process.await child with
531
581
| `Exited 0 -> Ok (Buffer.contents buf_stdout |> String.trim)
532
582
| _ ->
533
-
let result = Git.{
534
-
exit_code = 1;
535
-
stdout = Buffer.contents buf_stdout;
536
-
stderr = Buffer.contents buf_stderr;
537
-
} in
583
+
let result =
584
+
Git.
585
+
{
586
+
exit_code = 1;
587
+
stdout = Buffer.contents buf_stdout;
588
+
stderr = Buffer.contents buf_stderr;
589
+
}
590
+
in
538
591
Error (Git.Command_failed (String.concat " " ("git" :: args), result))
539
592
540
593
let push_one ~proc ~fs ~config pkg =
541
-
let ( let* ) r f = Result.bind (Result.map_error (fun e -> Git_error e) r) f in
594
+
let ( let* ) r f =
595
+
Result.bind (Result.map_error (fun e -> Git_error e) r) f
596
+
in
542
597
let fs = fs_typed fs in
543
598
let monorepo = Config.Paths.monorepo config in
544
599
let prefix = Package.subtree_prefix pkg in
···
549
604
if not (Git.Subtree.exists ~fs ~repo:monorepo ~prefix) then begin
550
605
Log.debug (fun m -> m "Subtree %s not in monorepo, skipping" prefix);
551
606
Ok ()
552
-
end else begin
607
+
end
608
+
else begin
553
609
let checkout_eio = Eio.Path.(fs / Fpath.to_string checkout_dir) in
554
610
match Eio.Path.kind ~follow:true checkout_eio with
555
611
| exception Eio.Io _ ->
556
-
Log.debug (fun m -> m "Checkout %a does not exist, skipping" Fpath.pp checkout_dir);
612
+
Log.debug (fun m ->
613
+
m "Checkout %a does not exist, skipping" Fpath.pp checkout_dir);
557
614
Ok ()
558
615
| `Directory when Git.is_repo ~proc ~fs checkout_dir ->
559
616
let monorepo_eio = Eio.Path.(fs / Fpath.to_string monorepo) in
560
617
let checkout_path = Fpath.to_string checkout_dir in
561
618
(* Push subtree to a sync branch (avoids "branch is checked out" error) *)
562
619
Log.info (fun m -> m "Pushing subtree %s to checkout" prefix);
563
-
let* _ = run_git_in ~proc ~cwd:monorepo_eio
564
-
[ "subtree"; "push"; "--prefix"; prefix; checkout_path; sync_branch ] in
620
+
let* _ =
621
+
run_git_in ~proc ~cwd:monorepo_eio
622
+
[
623
+
"subtree"; "push"; "--prefix"; prefix; checkout_path; sync_branch;
624
+
]
625
+
in
565
626
(* Merge sync branch into the target branch in checkout *)
566
627
Log.debug (fun m -> m "Merging %s into %s" sync_branch branch);
567
-
let* _ = run_git_in ~proc ~cwd:checkout_eio [ "merge"; "--ff-only"; sync_branch ] in
628
+
let* _ =
629
+
run_git_in ~proc ~cwd:checkout_eio
630
+
[ "merge"; "--ff-only"; sync_branch ]
631
+
in
568
632
(* Delete the sync branch *)
569
633
Log.debug (fun m -> m "Cleaning up %s branch" sync_branch);
570
-
ignore (run_git_in ~proc ~cwd:checkout_eio [ "branch"; "-d"; sync_branch ]);
634
+
ignore
635
+
(run_git_in ~proc ~cwd:checkout_eio [ "branch"; "-d"; sync_branch ]);
571
636
Ok ()
572
637
| _ ->
573
-
Log.debug (fun m -> m "Checkout %a is not a git repo, skipping" Fpath.pp checkout_dir);
638
+
Log.debug (fun m ->
639
+
m "Checkout %a is not a git repo, skipping" Fpath.pp checkout_dir);
574
640
Ok ()
575
641
end
576
642
···
589
655
if pkgs = [] && package <> None then
590
656
Error (Package_not_found (Option.get package))
591
657
else begin
592
-
Log.info (fun m -> m "Checking status of %d packages" (List.length pkgs));
658
+
Log.info (fun m ->
659
+
m "Checking status of %d packages" (List.length pkgs));
593
660
let statuses = Status.compute_all ~proc ~fs:fs_t ~config pkgs in
594
661
let dirty =
595
662
List.filter Status.has_local_changes statuses
···
602
669
let total = List.length repos in
603
670
let rec loop i = function
604
671
| [] -> Ok ()
605
-
| pkg :: rest ->
606
-
Log.info (fun m -> m "[%d/%d] Processing %s" i total (Package.subtree_prefix pkg));
672
+
| pkg :: rest -> (
673
+
Log.info (fun m ->
674
+
m "[%d/%d] Processing %s" i total
675
+
(Package.subtree_prefix pkg));
607
676
match push_one ~proc ~fs ~config pkg with
608
677
| Ok () -> loop (i + 1) rest
609
-
| Error e -> Error e
678
+
| Error e -> Error e)
610
679
in
611
680
loop 1 repos
612
681
end
···
617
686
ensure_checkouts_dir ~fs:fs_t ~config;
618
687
match ensure_monorepo_initialized ~proc ~fs:fs_t ~config with
619
688
| Error e -> Error e
620
-
| Ok () ->
689
+
| Ok () -> (
621
690
match find_package ~fs:(fs_t :> _ Eio.Path.t) ~config package with
622
691
| Error e -> Error e
623
-
| Ok pkg ->
692
+
| Ok pkg -> (
624
693
Log.info (fun m -> m "Adding package %s" (Package.name pkg));
625
694
match ensure_checkout ~proc ~fs:fs_t ~config pkg with
626
695
| Error e -> Error (Git_error e)
627
696
| Ok () ->
628
-
pull_subtree ~proc ~fs ~config pkg
629
-
|> Result.map (fun _ -> ())
697
+
pull_subtree ~proc ~fs ~config pkg |> Result.map (fun _ -> ())))
630
698
631
699
let remove ~proc:_ ~fs ~config ~package () =
632
700
let fs = fs_typed fs in
···
638
706
try
639
707
Eio.Path.rmtree subtree_path;
640
708
Ok ()
641
-
with Eio.Io _ as e -> Error (Git_error (Git.Io_error (Printexc.to_string e)))
709
+
with Eio.Io _ as e ->
710
+
Error (Git_error (Git.Io_error (Printexc.to_string e)))
+50
-60
lib/monopam.mli
+50
-60
lib/monopam.mli
···
1
1
(** Monopam - Opam overlay and monorepo manager.
2
2
3
3
Monopam manages synchronization between an opam overlay repository,
4
-
individual git checkouts of packages, and a monorepo using git
5
-
subtrees.
4
+
individual git checkouts of packages, and a monorepo using git subtrees.
6
5
7
6
{1 Overview}
8
7
9
8
The typical workflow is:
10
9
11
-
1. {b init} - Initialize configuration and monorepo
12
-
2. {b status} - Check synchronization state of all packages
13
-
3. {b pull} - Fetch from remotes, update checkouts, merge to monorepo
14
-
4. {b push} - Extract monorepo changes back to checkouts
10
+
1. {b init} - Initialize configuration and monorepo 2. {b status} - Check
11
+
synchronization state of all packages 3. {b pull} - Fetch from remotes,
12
+
update checkouts, merge to monorepo 4. {b push} - Extract monorepo changes
13
+
back to checkouts
15
14
16
15
{1 Modules}
17
16
···
33
32
34
33
(** Errors from high-level operations. *)
35
34
type error =
36
-
| Config_error of string
37
-
(** Configuration error *)
38
-
| Repo_error of Opam_repo.error
39
-
(** Opam repository error *)
40
-
| Git_error of Git.error
41
-
(** Git operation error *)
35
+
| Config_error of string (** Configuration error *)
36
+
| Repo_error of Opam_repo.error (** Opam repository error *)
37
+
| Git_error of Git.error (** Git operation error *)
42
38
| Dirty_state of Package.t list
43
39
(** Operation blocked due to dirty packages *)
44
-
| Package_not_found of string
45
-
(** Named package not found in opam repo *)
40
+
| Package_not_found of string (** Named package not found in opam repo *)
46
41
47
-
(** [pp_error] formats errors. *)
48
42
val pp_error : error Fmt.t
43
+
(** [pp_error] formats errors. *)
49
44
50
45
(** {2 Status} *)
51
46
52
-
(** [status ~proc ~fs ~config ()] computes status for all packages
53
-
discovered in the opam repo.
54
-
55
-
@param proc Eio process manager
56
-
@param fs Eio filesystem
57
-
@param config Monopam configuration *)
58
47
val status :
59
48
proc:_ Eio.Process.mgr ->
60
49
fs:Eio.Fs.dir_ty Eio.Path.t ->
61
50
config:Config.t ->
62
51
unit ->
63
52
(Status.t list, error) result
53
+
(** [status ~proc ~fs ~config ()] computes status for all packages discovered in
54
+
the opam repo.
55
+
56
+
@param proc Eio process manager
57
+
@param fs Eio filesystem
58
+
@param config Monopam configuration *)
64
59
65
60
(** {2 Pull} *)
66
61
62
+
val pull :
63
+
proc:_ Eio.Process.mgr ->
64
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
65
+
config:Config.t ->
66
+
?package:string ->
67
+
unit ->
68
+
(unit, error) result
67
69
(** [pull ~proc ~fs ~config ?package ()] pulls updates from remotes.
68
70
69
-
For each package (or the specified package):
70
-
1. Clones or fetches the individual checkout
71
-
2. Adds or pulls the subtree in the monorepo
71
+
For each package (or the specified package): 1. Clones or fetches the
72
+
individual checkout 2. Adds or pulls the subtree in the monorepo
72
73
73
74
Aborts if any checkout or the monorepo has uncommitted changes.
74
75
···
76
77
@param fs Eio filesystem
77
78
@param config Monopam configuration
78
79
@param package Optional specific package to pull *)
79
-
val pull :
80
+
81
+
(** {2 Push} *)
82
+
83
+
val push :
80
84
proc:_ Eio.Process.mgr ->
81
85
fs:Eio.Fs.dir_ty Eio.Path.t ->
82
86
config:Config.t ->
83
87
?package:string ->
84
88
unit ->
85
89
(unit, error) result
86
-
87
-
(** {2 Push} *)
90
+
(** [push ~proc ~fs ~config ?package ()] pushes changes from monorepo to
91
+
checkouts.
88
92
89
-
(** [push ~proc ~fs ~config ?package ()] pushes changes from monorepo
90
-
to checkouts.
91
-
92
-
For each package (or the specified package) with changes in the
93
-
monorepo:
94
-
1. Splits the subtree commits
95
-
2. Pushes to the individual checkout
93
+
For each package (or the specified package) with changes in the monorepo: 1.
94
+
Splits the subtree commits 2. Pushes to the individual checkout
96
95
97
96
The user must manually push from checkouts to remotes.
98
97
···
102
101
@param fs Eio filesystem
103
102
@param config Monopam configuration
104
103
@param package Optional specific package to push *)
105
-
val push :
104
+
105
+
(** {2 Package Management} *)
106
+
107
+
val add :
106
108
proc:_ Eio.Process.mgr ->
107
109
fs:Eio.Fs.dir_ty Eio.Path.t ->
108
110
config:Config.t ->
109
-
?package:string ->
111
+
package:string ->
110
112
unit ->
111
113
(unit, error) result
112
-
113
-
(** {2 Package Management} *)
114
-
115
114
(** [add ~proc ~fs ~config ~package ()] adds a package to the monorepo.
116
115
117
116
Clones the checkout if needed and adds the subtree.
···
120
119
@param fs Eio filesystem
121
120
@param config Monopam configuration
122
121
@param package Package name to add *)
123
-
val add :
122
+
123
+
val remove :
124
124
proc:_ Eio.Process.mgr ->
125
125
fs:Eio.Fs.dir_ty Eio.Path.t ->
126
126
config:Config.t ->
127
127
package:string ->
128
128
unit ->
129
129
(unit, error) result
130
-
131
-
(** [remove ~proc ~fs ~config ~package ()] removes a package from the
132
-
monorepo.
130
+
(** [remove ~proc ~fs ~config ~package ()] removes a package from the monorepo.
133
131
134
132
Removes the subtree directory but does not delete the checkout.
135
133
···
137
135
@param fs Eio filesystem
138
136
@param config Monopam configuration
139
137
@param package Package name to remove *)
140
-
val remove :
141
-
proc:_ Eio.Process.mgr ->
142
-
fs:Eio.Fs.dir_ty Eio.Path.t ->
143
-
config:Config.t ->
144
-
package:string ->
145
-
unit ->
146
-
(unit, error) result
147
138
148
139
(** {1 Package Discovery} *)
149
140
150
-
(** [discover_packages ~fs ~config ()] scans the opam repo and returns
151
-
all packages.
152
-
153
-
@param fs Eio filesystem
154
-
@param config Monopam configuration *)
155
141
val discover_packages :
156
142
fs:Eio.Fs.dir_ty Eio.Path.t ->
157
143
config:Config.t ->
158
144
unit ->
159
145
(Package.t list, error) result
146
+
(** [discover_packages ~fs ~config ()] scans the opam repo and returns all
147
+
packages.
160
148
161
-
(** [find_package ~fs ~config name] finds a package by name in the
162
-
opam repo.
149
+
@param fs Eio filesystem
150
+
@param config Monopam configuration *)
163
151
164
-
@param fs Eio filesystem
165
-
@param config Monopam configuration
166
-
@param name Package name to find *)
167
152
val find_package :
168
153
fs:Eio.Fs.dir_ty Eio.Path.t ->
169
154
config:Config.t ->
170
155
string ->
171
156
(Package.t, error) result
157
+
(** [find_package ~fs ~config name] finds a package by name in the opam repo.
158
+
159
+
@param fs Eio filesystem
160
+
@param config Monopam configuration
161
+
@param name Package name to find *)
+14
-21
lib/opam_repo.ml
+14
-21
lib/opam_repo.ml
···
19
19
| Parse_error (path, msg) -> Fmt.pf ppf "Failed to parse %s: %s" path msg
20
20
| Io_error msg -> Fmt.pf ppf "I/O error: %s" msg
21
21
22
-
let has_prefix prefix s =
23
-
String.length s >= String.length prefix &&
24
-
String.sub s 0 (String.length prefix) = prefix
25
-
26
-
let has_suffix suffix s =
27
-
String.length s >= String.length suffix &&
28
-
String.sub s (String.length s - String.length suffix) (String.length suffix) = suffix
29
-
30
22
let is_git_url url =
31
-
String.length url > 0 &&
32
-
(has_prefix "git+" url || has_prefix "git://" url ||
33
-
has_prefix "git@" url || has_suffix ".git" url)
23
+
String.starts_with ~prefix:"git+" url
24
+
|| String.starts_with ~prefix:"git://" url
25
+
|| String.starts_with ~prefix:"git@" url
26
+
|| String.ends_with ~suffix:".git" url
34
27
35
28
let normalize_git_url url =
36
29
let url =
37
-
if has_prefix "git+" url then
38
-
String.sub url 4 (String.length url - 4)
39
-
else url
30
+
match String.starts_with ~prefix:"git+" url with
31
+
| true -> String.sub url 4 (String.length url - 4)
32
+
| false -> url
40
33
in
41
34
Uri.of_string url
42
35
···
70
63
let load_package ~fs opam_file_path =
71
64
let path_str = Fpath.to_string opam_file_path in
72
65
match parse_package_path opam_file_path with
73
-
| None -> Error (Parse_error (path_str, "Cannot determine package name/version"))
66
+
| None ->
67
+
Error (Parse_error (path_str, "Cannot determine package name/version"))
74
68
| Some (name, version) -> (
75
69
try
76
70
let eio_path = Eio.Path.(fs / path_str) in
···
92
86
try
93
87
Eio.Path.read_dir eio_path
94
88
|> List.filter (fun name ->
95
-
let child = Eio.Path.(eio_path / name) in
96
-
match Eio.Path.kind ~follow:false child with
97
-
| `Directory -> true
98
-
| _ -> false)
89
+
let child = Eio.Path.(eio_path / name) in
90
+
match Eio.Path.kind ~follow:false child with
91
+
| `Directory -> true
92
+
| _ -> false)
99
93
with Eio.Io _ -> []
100
94
101
95
let scan_all ~fs repo_path =
···
113
107
match load_package ~fs opam_path with
114
108
| Ok pkg -> (pkg :: pkgs, errs)
115
109
| Error e -> (pkgs, e :: errs))
116
-
| _ :: _ :: _ as vs ->
117
-
(pkgs, Multiple_versions (name, vs) :: errs))
110
+
| _ :: _ :: _ as vs -> (pkgs, Multiple_versions (name, vs) :: errs))
118
111
([], []) package_names
119
112
in
120
113
(List.rev packages, List.rev errors)
+23
-37
lib/opam_repo.mli
+23
-37
lib/opam_repo.mli
···
1
1
(** Opam repository scanning and package discovery.
2
2
3
-
This module scans an opam overlay repository to discover packages
4
-
and extract their git remote URLs. It enforces the monopam constraints:
3
+
This module scans an opam overlay repository to discover packages and
4
+
extract their git remote URLs. It enforces the monopam constraints:
5
5
- Only one version per package is allowed
6
6
- Only git remotes are allowed (no archive URLs) *)
7
7
···
11
11
type error =
12
12
| Multiple_versions of string * string list
13
13
(** Package has multiple versions: (name, versions) *)
14
-
| No_dev_repo of string
15
-
(** Package has no dev-repo field *)
14
+
| No_dev_repo of string (** Package has no dev-repo field *)
16
15
| Invalid_dev_repo of string * string
17
16
(** Package has invalid dev-repo: (name, url) *)
18
17
| Not_git_remote of string * string
19
18
(** Package dev-repo is not a git URL: (name, url) *)
20
19
| Parse_error of string * string
21
20
(** Failed to parse opam file: (path, message) *)
22
-
| Io_error of string
23
-
(** Filesystem error *)
21
+
| Io_error of string (** Filesystem error *)
24
22
25
-
(** [pp_error] is a formatter for errors. *)
26
23
val pp_error : error Fmt.t
24
+
(** [pp_error] is a formatter for errors. *)
27
25
28
26
(** {1 Scanning} *)
29
27
30
-
(** [scan ~fs repo_path] scans the opam repository at [repo_path] and
31
-
returns all discovered packages.
28
+
val scan : fs:_ Eio.Path.t -> Fpath.t -> (Package.t list, error) result
29
+
(** [scan ~fs repo_path] scans the opam repository at [repo_path] and returns
30
+
all discovered packages.
32
31
33
32
The repository is expected to have the standard opam layout:
34
33
[repo_path/packages/<name>/<name.version>/opam]
···
40
39
41
40
@param fs Eio filesystem capability
42
41
@param repo_path Path to the opam repository root *)
43
-
val scan :
44
-
fs:_ Eio.Path.t ->
45
-
Fpath.t ->
46
-
(Package.t list, error) result
47
42
48
-
(** [scan_all ~fs repo_path] scans the repository and returns all
49
-
packages, collecting errors instead of failing on the first one.
43
+
val scan_all : fs:_ Eio.Path.t -> Fpath.t -> Package.t list * error list
44
+
(** [scan_all ~fs repo_path] scans the repository and returns all packages,
45
+
collecting errors instead of failing on the first one.
50
46
51
47
Returns a pair of (valid packages, errors encountered). *)
52
-
val scan_all :
53
-
fs:_ Eio.Path.t ->
54
-
Fpath.t ->
55
-
Package.t list * error list
56
48
57
49
(** {1 Individual Package Loading} *)
58
50
59
-
(** [load_package ~fs opam_file_path] loads a single package from its
60
-
opam file path.
51
+
val load_package : fs:_ Eio.Path.t -> Fpath.t -> (Package.t, error) result
52
+
(** [load_package ~fs opam_file_path] loads a single package from its opam file
53
+
path.
61
54
62
55
@param fs Eio filesystem capability
63
56
@param opam_file_path Full path to the opam file *)
64
-
val load_package :
65
-
fs:_ Eio.Path.t ->
66
-
Fpath.t ->
67
-
(Package.t, error) result
68
57
69
58
(** {1 Validation} *)
70
59
71
-
(** [validate_repo ~fs repo_path] validates the entire repository
72
-
without loading packages. Returns a list of validation errors.
60
+
val validate_repo : fs:_ Eio.Path.t -> Fpath.t -> error list
61
+
(** [validate_repo ~fs repo_path] validates the entire repository without
62
+
loading packages. Returns a list of validation errors.
73
63
74
64
This is useful for checking repository health before operations. *)
75
-
val validate_repo :
76
-
fs:_ Eio.Path.t ->
77
-
Fpath.t ->
78
-
error list
79
65
66
+
val is_git_url : string -> bool
80
67
(** [is_git_url url] returns true if the URL is a valid git remote.
81
68
82
-
Accepts URLs starting with "git+" or "git://" or ending with ".git",
83
-
as well as SSH-style URLs like "git\@github.com:...". *)
84
-
val is_git_url : string -> bool
69
+
Accepts URLs starting with "git+" or "git://" or ending with ".git", as well
70
+
as SSH-style URLs like "git@github.com:...". *)
85
71
86
-
(** [normalize_git_url url] normalizes a git URL by removing the "git+"
87
-
prefix if present.
72
+
val normalize_git_url : string -> Uri.t
73
+
(** [normalize_git_url url] normalizes a git URL by removing the "git+" prefix
74
+
if present.
88
75
89
76
For example, "git+https://example.com/repo.git" becomes
90
77
"https://example.com/repo.git". *)
91
-
val normalize_git_url : string -> Uri.t
+9
-6
lib/package.ml
+9
-6
lib/package.ml
···
5
5
branch : string option;
6
6
}
7
7
8
-
let create ~name ~version ~dev_repo ?branch () = { name; version; dev_repo; branch }
8
+
let create ~name ~version ~dev_repo ?branch () =
9
+
{ name; version; dev_repo; branch }
10
+
9
11
let name t = t.name
10
12
let version t = t.version
11
13
let dev_repo t = t.dev_repo
···
17
19
let basename = Filename.basename path in
18
20
if Filename.check_suffix basename ".git" then
19
21
Filename.chop_suffix basename ".git"
20
-
else
21
-
basename
22
+
else basename
22
23
23
24
let checkout_dir ~checkouts_root t = Fpath.(checkouts_root / repo_name t)
24
25
let subtree_prefix t = repo_name t
25
26
let compare a b = String.compare a.name b.name
26
27
let equal a b = String.equal a.name b.name
27
-
28
28
let same_repo a b = Uri.equal a.dev_repo b.dev_repo
29
29
30
30
let pp ppf t =
31
-
Fmt.pf ppf "@[<hov 2>{ name = %S;@ version = %S;@ dev_repo = %a;@ branch = %a }@]"
32
-
t.name t.version Uri.pp t.dev_repo Fmt.(option ~none:(any "None") string) t.branch
31
+
Fmt.pf ppf
32
+
"@[<hov 2>{ name = %S;@ version = %S;@ dev_repo = %a;@ branch = %a }@]"
33
+
t.name t.version Uri.pp t.dev_repo
34
+
Fmt.(option ~none:(any "None") string)
35
+
t.branch
+19
-24
lib/package.mli
+19
-24
lib/package.mli
···
1
1
(** Package metadata and operations.
2
2
3
-
A package represents a single opam package discovered from the opam
4
-
overlay repository. It contains the package name, version, git remote
5
-
URL, and optional configuration overrides. *)
3
+
A package represents a single opam package discovered from the opam overlay
4
+
repository. It contains the package name, version, git remote URL, and
5
+
optional configuration overrides. *)
6
6
7
7
(** {1 Types} *)
8
8
9
-
(** A package discovered from the opam overlay. *)
10
9
type t
10
+
(** A package discovered from the opam overlay. *)
11
11
12
12
(** {1 Constructors} *)
13
13
14
+
val create :
15
+
name:string -> version:string -> dev_repo:Uri.t -> ?branch:string -> unit -> t
14
16
(** [create ~name ~version ~dev_repo ?branch ()] creates a new package.
15
17
16
18
@param name The opam package name
17
19
@param version The package version (e.g., "dev")
18
20
@param dev_repo The git remote URL from the opam file's dev-repo field
19
21
@param branch Optional branch override; defaults to repository default *)
20
-
val create :
21
-
name:string ->
22
-
version:string ->
23
-
dev_repo:Uri.t ->
24
-
?branch:string ->
25
-
unit ->
26
-
t
27
22
28
23
(** {1 Accessors} *)
29
24
30
-
(** [name t] returns the package name. *)
31
25
val name : t -> string
26
+
(** [name t] returns the package name. *)
32
27
28
+
val version : t -> string
33
29
(** [version t] returns the package version string. *)
34
-
val version : t -> string
35
30
31
+
val dev_repo : t -> Uri.t
36
32
(** [dev_repo t] returns the git remote URI. *)
37
-
val dev_repo : t -> Uri.t
38
33
34
+
val branch : t -> string option
39
35
(** [branch t] returns the branch to track, if explicitly set. *)
40
-
val branch : t -> string option
41
36
37
+
val repo_name : t -> string
42
38
(** [repo_name t] returns the repository name extracted from the dev-repo URL.
43
39
44
-
This is the basename of the URL path with any ".git" suffix removed.
45
-
For example, "https://github.com/foo/bar.git" returns "bar". *)
46
-
val repo_name : t -> string
40
+
This is the basename of the URL path with any ".git" suffix removed. For
41
+
example, "https://github.com/foo/bar.git" returns "bar". *)
47
42
48
43
(** {1 Derived Paths} *)
49
44
45
+
val checkout_dir : checkouts_root:Fpath.t -> t -> Fpath.t
50
46
(** [checkout_dir ~checkouts_root t] returns the expected path for this
51
47
package's git checkout, based on the repository name.
52
48
···
54
50
checkouts_root "/home/user/src", this returns "/home/user/src/bar".
55
51
56
52
Multiple packages from the same repository will share the same checkout. *)
57
-
val checkout_dir : checkouts_root:Fpath.t -> t -> Fpath.t
58
53
54
+
val subtree_prefix : t -> string
59
55
(** [subtree_prefix t] returns the subdirectory name used in the monorepo.
60
56
61
57
This is the repository name (same as [repo_name t]), so multiple packages
62
58
from the same repository share the same subtree directory. *)
63
-
val subtree_prefix : t -> string
64
59
65
60
(** {1 Comparison} *)
66
61
62
+
val compare : t -> t -> int
67
63
(** [compare a b] compares packages by name. *)
68
-
val compare : t -> t -> int
69
64
70
-
(** [equal a b] returns true if packages have the same name. *)
71
65
val equal : t -> t -> bool
66
+
(** [equal a b] returns true if packages have the same name. *)
72
67
68
+
val same_repo : t -> t -> bool
73
69
(** [same_repo a b] returns true if packages share the same dev-repo URL. *)
74
-
val same_repo : t -> t -> bool
75
70
76
71
(** {1 Pretty Printing} *)
77
72
78
-
(** [pp] is a formatter for packages. *)
79
73
val pp : t Fmt.t
74
+
(** [pp] is a formatter for packages. *)
+10
-13
lib/status.ml
+10
-13
lib/status.ml
···
13
13
}
14
14
15
15
let fs_typed (fs : _ Eio.Path.t) : Eio.Fs.dir_ty Eio.Path.t =
16
-
let (dir, _) = fs in
16
+
let dir, _ = fs in
17
17
(dir, "")
18
18
19
19
let compute ~proc ~fs ~config pkg =
···
23
23
let prefix = Package.subtree_prefix pkg in
24
24
let fs_t = fs_typed fs in
25
25
let fs_dir =
26
-
let (dir, _) = fs in
26
+
let dir, _ = fs in
27
27
(dir, Fpath.to_string checkout_dir)
28
28
in
29
29
let checkout =
30
30
match Eio.Path.kind ~follow:true fs_dir with
31
31
| exception Eio.Io _ -> Missing
32
-
| `Directory ->
32
+
| `Directory -> (
33
33
if not (Git.is_repo ~proc ~fs:fs_t checkout_dir) then Not_a_repo
34
34
else if Git.is_dirty ~proc ~fs:fs_t checkout_dir then Dirty
35
-
else (
35
+
else
36
36
match Git.ahead_behind ~proc ~fs:fs_t checkout_dir with
37
37
| Ok ab -> Clean ab
38
38
| Error _ -> Clean { ahead = 0; behind = 0 })
···
47
47
let compute_all ~proc ~fs ~config packages =
48
48
List.map (compute ~proc ~fs ~config) packages
49
49
50
-
let is_checkout_clean t =
51
-
match t.checkout with Clean _ -> true | _ -> false
52
-
53
-
let has_local_changes t =
54
-
match t.checkout with Dirty -> true | _ -> false
50
+
let is_checkout_clean t = match t.checkout with Clean _ -> true | _ -> false
51
+
let has_local_changes t = match t.checkout with Dirty -> true | _ -> false
55
52
56
53
let needs_pull t =
57
54
match t.checkout with Clean ab -> ab.behind > 0 | _ -> false
58
55
59
-
let needs_push t =
60
-
match t.checkout with Clean ab -> ab.ahead > 0 | _ -> false
56
+
let needs_push t = match t.checkout with Clean ab -> ab.ahead > 0 | _ -> false
61
57
62
58
let is_fully_synced t =
63
59
match (t.checkout, t.subtree) with
···
92
88
let total = List.length statuses in
93
89
let clean = List.filter is_checkout_clean statuses |> List.length in
94
90
let synced = List.filter is_fully_synced statuses |> List.length in
95
-
Fmt.pf ppf "@[<v>Packages: %d total, %d clean checkouts, %d fully synced@,@,%a@]"
96
-
total clean synced
91
+
Fmt.pf ppf
92
+
"@[<v>Packages: %d total, %d clean checkouts, %d fully synced@,@,%a@]" total
93
+
clean synced
97
94
Fmt.(list ~sep:cut pp)
98
95
statuses
+32
-38
lib/status.mli
+32
-38
lib/status.mli
···
1
1
(** Status computation and display.
2
2
3
-
This module computes the synchronization status of packages across
4
-
the three locations: git remote, individual checkout, and monorepo
5
-
subtree. *)
3
+
This module computes the synchronization status of packages across the three
4
+
locations: git remote, individual checkout, and monorepo subtree. *)
6
5
7
6
(** {1 Types} *)
8
7
9
8
(** Status of an individual checkout relative to its remote. *)
10
9
type checkout_status =
11
-
| Missing
12
-
(** Checkout directory does not exist *)
13
-
| Not_a_repo
14
-
(** Directory exists but is not a git repository *)
15
-
| Dirty
16
-
(** Has uncommitted changes *)
10
+
| Missing (** Checkout directory does not exist *)
11
+
| Not_a_repo (** Directory exists but is not a git repository *)
12
+
| Dirty (** Has uncommitted changes *)
17
13
| Clean of Git.ahead_behind
18
14
(** Clean with ahead/behind info relative to remote *)
19
15
20
16
(** Status of a subtree in the monorepo. *)
21
17
type subtree_status =
22
-
| Not_added
23
-
(** Subtree has not been added to monorepo *)
24
-
| Present
25
-
(** Subtree exists in monorepo *)
18
+
| Not_added (** Subtree has not been added to monorepo *)
19
+
| Present (** Subtree exists in monorepo *)
26
20
27
-
(** Combined status for a package. *)
28
21
type t = {
29
22
package : Package.t;
30
23
checkout : checkout_status;
31
24
subtree : subtree_status;
32
25
}
26
+
(** Combined status for a package. *)
33
27
34
28
(** {1 Status Computation} *)
35
29
36
-
(** [compute ~proc ~fs ~config pkg] computes the status of a single package.
37
-
38
-
@param proc Eio process manager
39
-
@param fs Eio filesystem
40
-
@param config Monopam configuration
41
-
@param pkg Package to check *)
42
30
val compute :
43
31
proc:_ Eio.Process.mgr ->
44
32
fs:Eio.Fs.dir_ty Eio.Path.t ->
45
33
config:Config.t ->
46
34
Package.t ->
47
35
t
48
-
49
-
(** [compute_all ~proc ~fs ~config packages] computes status for all
50
-
packages in parallel.
36
+
(** [compute ~proc ~fs ~config pkg] computes the status of a single package.
51
37
52
38
@param proc Eio process manager
53
39
@param fs Eio filesystem
54
40
@param config Monopam configuration
55
-
@param packages List of packages to check *)
41
+
@param pkg Package to check *)
42
+
56
43
val compute_all :
57
44
proc:_ Eio.Process.mgr ->
58
45
fs:Eio.Fs.dir_ty Eio.Path.t ->
59
46
config:Config.t ->
60
47
Package.t list ->
61
48
t list
49
+
(** [compute_all ~proc ~fs ~config packages] computes status for all packages in
50
+
parallel.
51
+
52
+
@param proc Eio process manager
53
+
@param fs Eio filesystem
54
+
@param config Monopam configuration
55
+
@param packages List of packages to check *)
62
56
63
57
(** {1 Predicates} *)
64
58
65
-
(** [is_checkout_clean t] returns true if the checkout is clean
66
-
(exists, is a repo, and has no uncommitted changes). *)
67
59
val is_checkout_clean : t -> bool
60
+
(** [is_checkout_clean t] returns true if the checkout is clean (exists, is a
61
+
repo, and has no uncommitted changes). *)
68
62
69
-
(** [has_local_changes t] returns true if either the checkout or
70
-
subtree has uncommitted local changes. *)
71
63
val has_local_changes : t -> bool
64
+
(** [has_local_changes t] returns true if either the checkout or subtree has
65
+
uncommitted local changes. *)
72
66
73
-
(** [needs_pull t] returns true if the checkout is behind the remote. *)
74
67
val needs_pull : t -> bool
68
+
(** [needs_pull t] returns true if the checkout is behind the remote. *)
75
69
70
+
val needs_push : t -> bool
76
71
(** [needs_push t] returns true if the checkout is ahead of the remote. *)
77
-
val needs_push : t -> bool
78
72
79
-
(** [is_fully_synced t] returns true if the package is fully in sync
80
-
across all locations. *)
81
73
val is_fully_synced : t -> bool
74
+
(** [is_fully_synced t] returns true if the package is fully in sync across all
75
+
locations. *)
82
76
83
77
(** {1 Filtering} *)
84
78
85
-
(** [filter_actionable statuses] returns only packages that need action
86
-
(dirty, ahead, behind, or missing subtree). *)
87
79
val filter_actionable : t list -> t list
80
+
(** [filter_actionable statuses] returns only packages that need action (dirty,
81
+
ahead, behind, or missing subtree). *)
88
82
89
83
(** {1 Pretty Printing} *)
90
84
91
-
(** [pp_checkout_status] formats checkout status. *)
92
85
val pp_checkout_status : checkout_status Fmt.t
86
+
(** [pp_checkout_status] formats checkout status. *)
93
87
94
-
(** [pp_subtree_status] formats subtree status. *)
95
88
val pp_subtree_status : subtree_status Fmt.t
89
+
(** [pp_subtree_status] formats subtree status. *)
96
90
97
-
(** [pp] formats a single package status. *)
98
91
val pp : t Fmt.t
92
+
(** [pp] formats a single package status. *)
99
93
100
-
(** [pp_summary] formats a summary of all package statuses. *)
101
94
val pp_summary : t list Fmt.t
95
+
(** [pp_summary] formats a summary of all package statuses. *)