forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
Upgrade to ocamlformat 0.29.0; fix csvt/sexpt streaming; reformat
- Update .ocamlformat to 0.29.0 across all 591 files
- csvt: reuse single Buffer.t for field reads (no alloc per field)
- sexpt: Obj members decoded from stream into Dict, typed Variant GADT
- Reformat all source files for 0.29.0
+440
-486
+4
-1
bin/cmd_add.ml
+4
-1
bin/cmd_add.ml
···
21
21
let proc = Eio.Stdenv.process_mgr env in
22
22
let target = Fpath.v (Sys.getcwd ()) in
23
23
let source = parse_source source in
24
-
match Monopam.Import.run ~proc ~fs ~target ~source ~name:dir ~dry_run () with
24
+
Eio.Switch.run @@ fun sw ->
25
+
match
26
+
Monopam.Import.run ~sw ~proc ~fs ~target ~source ~name:dir ~dry_run ()
27
+
with
25
28
| Ok results ->
26
29
if results = [] then Fmt.pr "Nothing added.@."
27
30
else begin
+2
-1
bin/cmd_clean.ml
+2
-1
bin/cmd_clean.ml
···
38
38
Common.with_config env @@ fun config ->
39
39
let fs = Eio.Stdenv.fs env in
40
40
let proc = Eio.Stdenv.process_mgr env in
41
-
match Monopam.Clean.run ~proc ~fs ~config ~dry_run ~force () with
41
+
Eio.Switch.run @@ fun sw ->
42
+
match Monopam.Clean.run ~sw ~proc ~fs ~config ~dry_run ~force () with
42
43
| Ok () -> `Ok ()
43
44
| Error e ->
44
45
Fmt.epr "Error: %a@." Monopam.Ctx.pp_error_with_hint e;
+2
-1
bin/cmd_deps.ml
+2
-1
bin/cmd_deps.ml
···
8
8
Eio_main.run @@ fun env ->
9
9
let fs = Eio.Stdenv.fs env in
10
10
let proc = Eio.Stdenv.process_mgr env in
11
+
Eio.Switch.run @@ fun sw ->
11
12
let target = Fpath.v (Sys.getcwd ()) in
12
-
match Monopam.Deps.run ~proc ~fs ~target ~dry_run () with
13
+
match Monopam.Deps.run ~sw ~proc ~fs ~target ~dry_run () with
13
14
| Ok () -> `Ok ()
14
15
| Error e ->
15
16
Fmt.epr "Error: %s@." e;
+5
-7
bin/cmd_diff.ml
+5
-7
bin/cmd_diff.ml
···
1
1
open Cmdliner
2
2
3
-
let print_diff ~fs ~config status incoming =
3
+
let print_diff ~sw ~fs ~config status incoming =
4
4
let pkg = status.Monopam.Status.package in
5
5
let repo_name = Monopam.Package.repo_name pkg in
6
6
let checkouts_root = Monopam.Config.Paths.checkouts config in
···
10
10
let base, tip =
11
11
if incoming then ("HEAD", "origin/main") else ("origin/main", "HEAD")
12
12
in
13
-
let repo =
14
-
Eio.Switch.run @@ fun sw ->
15
-
Git.Repository.open_repo ~sw ~fs:fs_t checkout_path
16
-
in
13
+
let repo = Git.Repository.open_repo ~sw ~fs:fs_t checkout_path in
17
14
match Git.Repository.log_range_refs repo ~base ~tip ~max_count:20 () with
18
15
| Ok [] -> false
19
16
| Ok entries ->
···
34
31
Eio_main.run @@ fun env ->
35
32
Common.with_config env @@ fun config ->
36
33
let fs = Eio.Stdenv.fs env in
37
-
match Monopam.status ~fs:(fs :> Eio.Fs.dir_ty Eio.Path.t) ~config () with
34
+
Eio.Switch.run @@ fun sw ->
35
+
match Monopam.status ~sw ~fs:(fs :> Eio.Fs.dir_ty Eio.Path.t) ~config () with
38
36
| Error e ->
39
37
Fmt.epr "Error: %a@." Monopam.pp_error_with_hint e;
40
38
`Error (false, "diff failed")
···
56
54
else begin
57
55
let has_diff =
58
56
List.exists
59
-
(fun status -> print_diff ~fs ~config status incoming)
57
+
(fun status -> print_diff ~sw ~fs ~config status incoming)
60
58
statuses
61
59
in
62
60
if not has_diff then Fmt.pr "No differences.@.";
+2
-1
bin/cmd_fetch.ml
+2
-1
bin/cmd_fetch.ml
···
45
45
Common.with_config env @@ fun config ->
46
46
let fs = Eio.Stdenv.fs env in
47
47
let proc = Eio.Stdenv.process_mgr env in
48
-
match Monopam.Ctx.status ~fs ~config () with
48
+
Eio.Switch.run @@ fun sw ->
49
+
match Monopam.Ctx.status ~sw ~fs ~config () with
49
50
| Error e ->
50
51
Fmt.epr "Error: %a@." Monopam.Ctx.pp_error_with_hint e;
51
52
`Error (false, "fetch failed")
+4
-2
bin/cmd_init.ml
+4
-2
bin/cmd_init.ml
···
56
56
Eio_main.run @@ fun env ->
57
57
let fs = Eio.Stdenv.fs env in
58
58
let proc = Eio.Stdenv.process_mgr env in
59
+
Eio.Switch.run @@ fun sw ->
59
60
let git_toplevel () =
60
61
try
61
62
let buf = Buffer.create 128 in
···
82
83
Fmt.pr "[init] handle: %s@." resolved_handle;
83
84
(* Step 2: Verse workspace setup (idempotent) *)
84
85
(match
85
-
Monopam.Verse.init ~proc ~fs ~root:target ~handle:resolved_handle ()
86
+
Monopam.Verse.init ~sw ~proc ~fs ~root:target ~handle:resolved_handle
87
+
()
86
88
with
87
89
| Ok () -> ()
88
90
| Error e ->
89
91
Fmt.pr "[init] verse: skipped (%a)@." Monopam.Verse.pp_error e);
90
92
(* Step 3: Bootstrap subtrees from sources.toml *)
91
-
(match Monopam.Deps.run ~proc ~fs ~target ~dry_run () with
93
+
(match Monopam.Deps.run ~sw ~proc ~fs ~target ~dry_run () with
92
94
| Ok () -> ()
93
95
| Error e -> Fmt.pr "[init] bootstrap: %s@." e);
94
96
(* Step 4: Regenerate root deps (dune-project + root.opam) *)
+3
-2
bin/cmd_publish.ml
+3
-2
bin/cmd_publish.ml
···
4
4
Eio_main.run @@ fun env ->
5
5
let fs = Eio.Stdenv.fs env in
6
6
let proc = Eio.Stdenv.process_mgr env in
7
+
Eio.Switch.run @@ fun sw ->
7
8
let source = Fpath.v (Sys.getcwd ()) in
8
9
let config_opt = Result.to_option (Common.load_config env) in
9
10
let target =
···
19
20
if dry_run then
20
21
Fmt.pr "Dry run: publishing from %a to %a@." Fpath.pp source Fpath.pp target;
21
22
match
22
-
Monopam.Opam_sync.run_from_cwd ~fs ~proc ~source ~target ~packages
23
+
Monopam.Opam_sync.run_from_cwd ~sw ~fs ~proc ~source ~target ~packages
23
24
~no_commit ~dry_run ()
24
25
with
25
26
| Error (`Config_error e) ->
···
31
32
| Some config when (not no_checkouts) && not dry_run -> (
32
33
Fmt.pr "@.Exporting to checkouts...@.";
33
34
match
34
-
Monopam.Push.run ~proc ~fs ~config ~packages ~upstream:false
35
+
Monopam.Push.run ~sw ~proc ~fs ~config ~packages ~upstream:false
35
36
~clean:false ~force:false ()
36
37
with
37
38
| Ok () -> Fmt.pr "Checkouts updated.@."
+2
-1
bin/cmd_pull.ml
+2
-1
bin/cmd_pull.ml
···
37
37
Common.with_config env @@ fun config ->
38
38
let fs = Eio.Stdenv.fs env in
39
39
let proc = Eio.Stdenv.process_mgr env in
40
-
match Monopam.Pull.run ~proc ~fs ~config ~packages () with
40
+
Eio.Switch.run @@ fun sw ->
41
+
match Monopam.Pull.run ~sw ~proc ~fs ~config ~packages () with
41
42
| Ok () ->
42
43
let elapsed = Unix.gettimeofday () -. t0 in
43
44
Fmt.pr "@.%a Monorepo updated in %a.@." Tty.Span.pp
+2
-1
bin/cmd_push.ml
+2
-1
bin/cmd_push.ml
···
102
102
Common.with_config env @@ fun config ->
103
103
let fs = Eio.Stdenv.fs env in
104
104
let proc = Eio.Stdenv.process_mgr env in
105
+
Eio.Switch.run @@ fun sw ->
105
106
match
106
-
Monopam.Push.run ~proc ~fs ~config ~packages ~upstream:(not local_only)
107
+
Monopam.Push.run ~sw ~proc ~fs ~config ~packages ~upstream:(not local_only)
107
108
~clean ~force ()
108
109
with
109
110
| Ok () ->
+4
-2
bin/cmd_status.ml
+4
-2
bin/cmd_status.ml
···
79
79
| Error _ -> ()
80
80
| Ok verse_config ->
81
81
let forks =
82
-
Monopam.Forks.compute ~proc ~fs ~verse_config ~monopam_config:config ()
82
+
Monopam.Forks.compute ~sw ~proc ~fs ~verse_config ~monopam_config:config
83
+
()
83
84
in
84
85
if forks.repos <> [] then
85
86
Fmt.pr "%a" (Monopam.Forks.pp_summary' ~show_all) forks
···
89
90
Common.with_config env @@ fun config ->
90
91
let fs = Eio.Stdenv.fs env in
91
92
let proc = Eio.Stdenv.process_mgr env in
92
-
match Monopam.status ~fs ~config () with
93
+
Eio.Switch.run @@ fun sw ->
94
+
match Monopam.status ~sw ~fs ~config () with
93
95
| Ok statuses ->
94
96
let sources = load_sources ~fs ~config in
95
97
let pp =
+22
-15
bin/cmd_verse.ml
+22
-15
bin/cmd_verse.ml
···
44
44
`Ok ()
45
45
end
46
46
47
-
let pull_inner ~proc ~fs ~config ~verse_config ~handle ~repo ~refresh =
47
+
let pull_inner ~sw ~proc ~fs ~config ~verse_config ~handle ~repo ~refresh =
48
48
match
49
-
Monopam.pull_from_handle ~proc ~fs ~config ~verse_config ~handle ?repo
49
+
Monopam.pull_from_handle ~sw ~proc ~fs ~config ~verse_config ~handle ?repo
50
50
~refresh ()
51
51
with
52
52
| Ok result -> handle_pull_result result handle
···
60
60
Common.with_verse_config env @@ fun verse_config ->
61
61
let fs = Eio.Stdenv.fs env in
62
62
let proc = Eio.Stdenv.process_mgr env in
63
-
pull_inner ~proc ~fs ~config ~verse_config ~handle ~repo ~refresh
63
+
Eio.Switch.run @@ fun sw ->
64
+
pull_inner ~sw ~proc ~fs ~config ~verse_config ~handle ~repo ~refresh
64
65
65
66
let pull_cmd =
66
67
let doc = "Pull commits from a verse member's forks" in
···
117
118
info.commit_patch;
118
119
`Ok ()
119
120
120
-
let handle_sha ~proc ~fs ~config ~verse_config ~sha ~refresh =
121
+
let handle_sha ~sw ~proc ~fs ~config ~verse_config ~sha ~refresh =
121
122
match
122
-
Monopam.diff_show_commit ~proc ~fs ~config ~verse_config ~sha ~refresh ()
123
+
Monopam.diff_show_commit ~sw ~proc ~fs ~config ~verse_config ~sha ~refresh
124
+
()
123
125
with
124
126
| Some info -> show_commit_info info
125
127
| None ->
126
128
Fmt.epr "Commit %s not found in any verse diff@." sha;
127
129
`Error (false, "commit not found")
128
130
129
-
let diff_inner ~proc ~fs ~config ~verse_config ~arg ~refresh ~patch =
131
+
let diff_inner ~sw ~proc ~fs ~config ~verse_config ~arg ~refresh ~patch =
130
132
match arg with
131
133
| Some sha when Monopam.is_commit_sha sha ->
132
-
handle_sha ~proc ~fs ~config ~verse_config ~sha ~refresh
134
+
handle_sha ~sw ~proc ~fs ~config ~verse_config ~sha ~refresh
133
135
| repo ->
134
136
let result =
135
-
Monopam.diff ~proc ~fs ~config ~verse_config ?repo ~refresh ~patch ()
137
+
Monopam.diff ~sw ~proc ~fs ~config ~verse_config ?repo ~refresh ~patch
138
+
()
136
139
in
137
140
Fmt.pr "%a" (Monopam.pp_diff_result ~show_patch:patch) result;
138
141
`Ok ()
···
143
146
Common.with_verse_config env @@ fun verse_config ->
144
147
let fs = Eio.Stdenv.fs env in
145
148
let proc = Eio.Stdenv.process_mgr env in
146
-
diff_inner ~proc ~fs ~config ~verse_config ~arg ~refresh ~patch
149
+
Eio.Switch.run @@ fun sw ->
150
+
diff_inner ~sw ~proc ~fs ~config ~verse_config ~arg ~refresh ~patch
147
151
148
152
let diff_cmd =
149
153
let doc = "Show diffs from verse members" in
···
182
186
let doc = "Force fresh fetches from all remotes." in
183
187
Arg.(value & flag & info [ "refresh"; "r" ] ~doc)
184
188
in
185
-
let cherrypick_inner ~proc ~fs ~config ~verse_config ~sha ~refresh =
189
+
let cherrypick_inner ~sw ~proc ~fs ~config ~verse_config ~sha ~refresh =
186
190
match
187
-
Monopam.cherrypick ~proc ~fs ~config ~verse_config ~sha ~refresh ()
191
+
Monopam.cherrypick ~sw ~proc ~fs ~config ~verse_config ~sha ~refresh ()
188
192
with
189
193
| Ok result ->
190
194
Fmt.pr "%a" Monopam.pp_cherrypick_result result;
···
200
204
Common.with_verse_config env @@ fun verse_config ->
201
205
let fs = Eio.Stdenv.fs env in
202
206
let proc = Eio.Stdenv.process_mgr env in
203
-
cherrypick_inner ~proc ~fs ~config ~verse_config ~sha ~refresh
207
+
Eio.Switch.run @@ fun sw ->
208
+
cherrypick_inner ~sw ~proc ~fs ~config ~verse_config ~sha ~refresh
204
209
in
205
210
Cmd.v info
206
211
Term.(ret (const run $ sha_arg $ refresh_arg $ Common.logging_term))
···
234
239
Common.with_config env @@ fun config ->
235
240
let fs = Eio.Stdenv.fs env in
236
241
let proc = Eio.Stdenv.process_mgr env in
242
+
Eio.Switch.run @@ fun sw ->
237
243
match Monopam.Verse_config.load ~fs () with
238
244
| Error _ ->
239
245
Fmt.epr "No verse configuration found. Run: monopam init@.";
240
246
`Error (false, "no verse config")
241
247
| Ok verse_config ->
242
248
let forks =
243
-
Monopam.Forks.compute ~proc ~fs ~verse_config ~monopam_config:config
244
-
()
249
+
Monopam.Forks.compute ~sw ~proc ~fs ~verse_config
250
+
~monopam_config:config ()
245
251
in
246
252
if forks.repos <> [] then
247
253
Fmt.pr "%a" (Monopam.Forks.pp_summary' ~show_all) forks;
···
267
273
Common.with_verse_config env @@ fun config ->
268
274
let fs = Eio.Stdenv.fs env in
269
275
let proc = Eio.Stdenv.process_mgr env in
270
-
match Monopam.Verse.members ~proc ~fs ~config () with
276
+
Eio.Switch.run @@ fun sw ->
277
+
match Monopam.Verse.members ~sw ~proc ~fs ~config () with
271
278
| Ok members ->
272
279
Fmt.pr "@[<v>%a@]@."
273
280
Fmt.(list ~sep:cut Monopam.Verse_registry.pp_member)
+3
-2
lib/add.ml
+3
-2
lib/add.ml
···
7
7
8
8
module Log = (val Logs.src_log src : Logs.LOG)
9
9
10
-
let run ~proc ~fs ~config ~package:pkg_name () =
10
+
let run ~sw ~proc ~fs ~config ~package:pkg_name () =
11
11
let fs_t = Ctx.fs_typed fs in
12
12
Ctx.ensure_checkouts_dir ~fs:fs_t ~config;
13
13
match Init.ensure ~proc ~fs:fs_t ~config with
···
20
20
match Ctx.ensure_checkout ~proc ~fs:fs_t ~config pkg with
21
21
| Error e -> Error (Ctx.Git_error e)
22
22
| Ok () ->
23
-
Pull.subtree ~proc ~fs ~config pkg |> Result.map (fun _ -> ())))
23
+
Pull.subtree ~sw ~proc ~fs ~config pkg |> Result.map (fun _ -> ())
24
+
))
+1
lib/add.mli
+1
lib/add.mli
+6
-8
lib/clean.ml
+6
-8
lib/clean.ml
···
31
31
32
32
(** {1 Helpers} *)
33
33
34
-
let check_and_fix ~fs_t ~dry_run ~name ~check_fn ~fix_fn path =
34
+
let check_and_fix ~sw ~fs_t ~dry_run ~name ~check_fn ~fix_fn path =
35
35
if not (Git.Repository.is_repo ~fs:fs_t path) then None
36
36
else
37
-
let repo =
38
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs:fs_t path
39
-
in
37
+
let repo = Git.Repository.open_repo ~sw ~fs:fs_t path in
40
38
match Git.Repository.head repo with
41
39
| None -> None
42
40
| Some head ->
···
84
82
Ok ()
85
83
end
86
84
87
-
let run ~proc ~fs ~config ~dry_run ~force () =
85
+
let run ~sw ~proc ~fs ~config ~dry_run ~force () =
88
86
let fs_t = Ctx.fs_typed fs in
89
87
let mono = Config.Paths.monorepo config in
90
88
let checkouts = Config.Paths.checkouts config in
91
89
let checkouts_path = Eio.Path.(fs_t / Fpath.to_string checkouts) in
92
90
let mono_cleaned =
93
-
check_and_fix ~fs_t ~dry_run ~name:"mono"
91
+
check_and_fix ~sw ~fs_t ~dry_run ~name:"mono"
94
92
~check_fn:(fun repo ~head -> Git.Subtree.check_mono repo ~head ())
95
93
~fix_fn:(fun repo ~head -> Git.Subtree.fix_mono repo ~head ())
96
94
mono
97
95
in
98
96
let checkout_results =
99
97
let clean_checkout name =
100
-
check_and_fix ~fs_t ~dry_run ~name
98
+
check_and_fix ~sw ~fs_t ~dry_run ~name
101
99
~check_fn:(fun repo ~head ->
102
100
Git.Subtree.check repo ~prefix:name ~head ())
103
101
~fix_fn:(fun repo ~head -> Git.Subtree.fix repo ~prefix:name ~head ())
···
108
106
in
109
107
let opam_repo_cleaned =
110
108
let opam_repo = Config.Paths.opam_repo config in
111
-
check_and_fix ~fs_t ~dry_run ~name:"opam-repo"
109
+
check_and_fix ~sw ~fs_t ~dry_run ~name:"opam-repo"
112
110
~check_fn:(fun repo ~head -> Git.Subtree.check_mono repo ~head ())
113
111
~fix_fn:(fun repo ~head -> Git.Subtree.fix_mono repo ~head ())
114
112
opam_repo
+2
-1
lib/clean.mli
+2
-1
lib/clean.mli
···
1
1
(** Clean empty commits from monorepo and checkouts. *)
2
2
3
3
val run :
4
+
sw:Eio.Switch.t ->
4
5
proc:_ Eio.Process.mgr ->
5
6
fs:Eio.Fs.dir_ty Eio.Path.t ->
6
7
config:Config.t ->
···
8
9
force:bool ->
9
10
unit ->
10
11
(unit, Ctx.error) result
11
-
(** [run ~proc ~fs ~config ~dry_run ~force ()] removes empty commits and
12
+
(** [run ~sw ~proc ~fs ~config ~dry_run ~force ()] removes empty commits and
12
13
unrelated merge commits from git history. *)
+12
-15
lib/cross_status.ml
+12
-15
lib/cross_status.ml
···
139
139
end
140
140
141
141
(** Get subtree info for a given prefix in a monorepo. *)
142
-
let subtree_info ~fs ~monorepo_path ~prefix () : subtree_info =
143
-
let repo =
144
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs monorepo_path
145
-
in
142
+
let subtree_info ~sw ~fs ~monorepo_path ~prefix () : subtree_info =
143
+
let repo = Git.Repository.open_repo ~sw ~fs monorepo_path in
146
144
let upstream_commit =
147
145
Git.Repository.subtree_last_upstream_commit repo ~prefix
148
146
in
···
151
149
(** Compare two subtree commits using a reference checkout. If checkout is
152
150
available, use it as the authoritative source. Otherwise, just check if
153
151
commits match. *)
154
-
let compare_commits ~fs ~checkout_path ~my_commit ~their_commit () =
152
+
let compare_commits ~sw ~fs ~checkout_path ~my_commit ~their_commit () =
155
153
match (my_commit, their_commit) with
156
154
| None, _ | _, None -> Unknown
157
155
| Some my, Some their when my = their -> Same
···
159
157
(* Try to compare using checkout if available *)
160
158
if not (Git.Repository.is_repo ~fs checkout_path) then Unknown
161
159
else begin
162
-
let repo =
163
-
Eio.Switch.run @@ fun sw ->
164
-
Git.Repository.open_repo ~sw ~fs checkout_path
165
-
in
160
+
let repo = Git.Repository.open_repo ~sw ~fs checkout_path in
166
161
let my_hash = Git.Hash.of_hex my in
167
162
let their_hash = Git.Hash.of_hex their in
168
163
(* Check if either is ancestor of the other *)
···
207
202
Diverged { my_ahead; their_ahead })
208
203
end
209
204
210
-
let compare_my_repo ~fs ~my_mono ~checkouts ~verse_subtrees repo_name =
211
-
let my_info = subtree_info ~fs ~monorepo_path:my_mono ~prefix:repo_name () in
205
+
let compare_my_repo ~sw ~fs ~my_mono ~checkouts ~verse_subtrees repo_name =
206
+
let my_info =
207
+
subtree_info ~sw ~fs ~monorepo_path:my_mono ~prefix:repo_name ()
208
+
in
212
209
let checkout_path = Fpath.(checkouts / repo_name) in
213
210
let others_with_repo =
214
211
try Hashtbl.find verse_subtrees repo_name with Not_found -> []
···
219
216
List.map
220
217
(fun (handle, their_mono) ->
221
218
let their_info =
222
-
subtree_info ~fs ~monorepo_path:their_mono ~prefix:repo_name ()
219
+
subtree_info ~sw ~fs ~monorepo_path:their_mono ~prefix:repo_name ()
223
220
in
224
221
let rel =
225
-
compare_commits ~fs ~checkout_path
222
+
compare_commits ~sw ~fs ~checkout_path
226
223
~my_commit:my_info.upstream_commit
227
224
~their_commit:their_info.upstream_commit ()
228
225
in
···
244
241
verse_subtrees []
245
242
|> List.sort (fun (a, _) (b, _) -> String.compare a b)
246
243
247
-
let compute ~fs ~verse_config ~monopam_config () =
244
+
let compute ~sw ~fs ~verse_config ~monopam_config () =
248
245
let my_mono = Verse_config.mono_path verse_config in
249
246
let checkouts = Config.Paths.checkouts monopam_config in
250
247
let my_subtrees = Verse.scan_subtrees ~fs my_mono in
251
248
let verse_subtrees = Verse.subtrees ~fs ~config:verse_config () in
252
249
let my_repos =
253
250
List.filter_map
254
-
(compare_my_repo ~fs ~my_mono ~checkouts ~verse_subtrees)
251
+
(compare_my_repo ~sw ~fs ~my_mono ~checkouts ~verse_subtrees)
255
252
my_subtrees
256
253
in
257
254
let other_repos = other_repos ~my_subtrees ~verse_subtrees in
+1
lib/cross_status.mli
+1
lib/cross_status.mli
+4
-6
lib/ctx.ml
+4
-6
lib/ctx.ml
···
194
194
| _ -> false
195
195
| exception Eio.Io _ -> false
196
196
197
-
let behind ~fs ~config pkg =
197
+
let behind ~sw ~fs ~config pkg =
198
198
let checkouts_root = Config.Paths.checkouts config in
199
199
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
200
200
let branch = branch ~config pkg in
201
201
if not (Git.Repository.is_repo ~fs checkout_dir) then 0
202
202
else
203
-
let repo =
204
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs checkout_dir
205
-
in
203
+
let repo = Git.Repository.open_repo ~sw ~fs checkout_dir in
206
204
match Git.Repository.ahead_behind repo ~branch () with
207
205
| Some ab -> ab.behind
208
206
| None -> 0
···
351
349
352
350
(** {1 Status} *)
353
351
354
-
let status ~fs ~config () =
352
+
let status ~sw ~fs ~config () =
355
353
let fs = fs_typed fs in
356
354
ensure_checkouts_dir ~fs ~config;
357
355
discover_packages ~fs:(fs :> _ Eio.Path.t) ~config ()
358
-
|> Result.map (Status.compute_all ~fs ~config)
356
+
|> Result.map (Status.compute_all ~sw ~fs ~config)
359
357
360
358
(** {1 Timing} *)
361
359
+10
-3
lib/ctx.mli
+10
-3
lib/ctx.mli
···
73
73
fs:Eio.Fs.dir_ty Eio.Path.t -> config:Config.t -> Package.t -> bool
74
74
(** [checkout_exists ~fs ~config pkg] returns [true] if the checkout exists. *)
75
75
76
-
val behind : fs:Eio.Fs.dir_ty Eio.Path.t -> config:Config.t -> Package.t -> int
77
-
(** [behind ~fs ~config pkg] returns the number of commits behind upstream. *)
76
+
val behind :
77
+
sw:Eio.Switch.t ->
78
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
79
+
config:Config.t ->
80
+
Package.t ->
81
+
int
82
+
(** [behind ~sw ~fs ~config pkg] returns the number of commits behind upstream.
83
+
*)
78
84
79
85
(** {1 Repository Grouping} *)
80
86
···
111
117
(** {1 Status} *)
112
118
113
119
val status :
120
+
sw:Eio.Switch.t ->
114
121
fs:Eio.Fs.dir_ty Eio.Path.t ->
115
122
config:Config.t ->
116
123
unit ->
117
124
(Status.t list, error) result
118
-
(** [status ~fs ~config ()] computes sync status for all packages. *)
125
+
(** [status ~sw ~fs ~config ()] computes sync status for all packages. *)
119
126
120
127
(** {1 Timing} *)
121
128
+4
-4
lib/deps.ml
+4
-4
lib/deps.ml
···
11
11
| _ -> false
12
12
| exception _ -> false
13
13
14
-
let import_entry ~proc ~fs ~target ~dry_run name
14
+
let import_entry ~sw ~proc ~fs ~target ~dry_run name
15
15
(entry : Sources_registry.entry) =
16
16
let prefix_path = Fpath.(target / name) in
17
17
if dir_exists ~fs prefix_path then begin
···
24
24
let ref_ = entry.ref_ in
25
25
Log.app (fun m -> m "[init] subtree %s: importing from %s" name url);
26
26
match
27
-
Import.git_url ~proc ~fs ~target ~url ~branch ~ref_ ~name:(Some name)
27
+
Import.git_url ~sw ~proc ~fs ~target ~url ~branch ~ref_ ~name:(Some name)
28
28
~dry_run
29
29
with
30
30
| Ok _result -> Ok ()
···
33
33
Error e
34
34
end
35
35
36
-
let run ~proc ~fs ~target ~dry_run () =
36
+
let run ~sw ~proc ~fs ~target ~dry_run () =
37
37
let sources_path = Fpath.(target / "sources.toml") in
38
38
let sources =
39
39
match Sources_registry.load ~fs sources_path with
···
45
45
let errors =
46
46
List.filter_map
47
47
(fun (name, entry) ->
48
-
match import_entry ~proc ~fs ~target ~dry_run name entry with
48
+
match import_entry ~sw ~proc ~fs ~target ~dry_run name entry with
49
49
| Ok () -> None
50
50
| Error e -> Some (Fmt.str "%s: %s" name e))
51
51
entries
+1
lib/deps.mli
+1
lib/deps.mli
+20
-29
lib/diff.ml
+20
-29
lib/diff.ml
···
111
111
112
112
(** {1 Diff Operations} *)
113
113
114
-
let check_source ~fs ~checkouts_path ~patch ~repo_name (handle, _src, rel) =
114
+
let check_source ~sw ~fs ~checkouts_path ~patch ~repo_name (handle, _src, rel) =
115
115
let checkout_path = Fpath.(checkouts_path / repo_name) in
116
116
if not (Git.Repository.is_repo ~fs checkout_path) then None
117
117
else begin
118
-
let repo =
119
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs checkout_path
120
-
in
118
+
let repo = Git.Repository.open_repo ~sw ~fs checkout_path in
121
119
let remote_name = "verse/" ^ handle in
122
120
let my_ref = "origin/main" in
123
121
let their_ref = remote_name ^ "/main" in
···
141
139
Some { repo_name; handle; relationship = rel; commits; patches }
142
140
end
143
141
144
-
let check_repo ~fs ~checkouts_path ~patch (r : Forks.repo_analysis) =
142
+
let check_repo ~sw ~fs ~checkouts_path ~patch (r : Forks.repo_analysis) =
145
143
let actionable =
146
144
List.filter
147
145
(fun (_, _, rel) ->
···
156
154
| sources -> (
157
155
let entries =
158
156
List.filter_map
159
-
(check_source ~fs ~checkouts_path ~patch ~repo_name:r.repo_name)
157
+
(check_source ~sw ~fs ~checkouts_path ~patch ~repo_name:r.repo_name)
160
158
sources
161
159
in
162
160
match entries with [] -> None | _ -> Some entries)
163
161
164
-
let compute ~proc ~fs ~config ~verse_config ?repo ?(refresh = false)
162
+
let compute ~sw ~proc ~fs ~config ~verse_config ?repo ?(refresh = false)
165
163
?(patch = false) () =
166
164
let checkouts_path = Config.Paths.checkouts config in
167
165
let forks =
168
-
Forks.compute ~proc ~fs ~verse_config ~monopam_config:config ~refresh ()
166
+
Forks.compute ~sw ~proc ~fs ~verse_config ~monopam_config:config ~refresh ()
169
167
in
170
168
let repos_to_check =
171
169
match repo with
···
173
171
| Some name -> List.filter (fun r -> r.Forks.repo_name = name) forks.repos
174
172
in
175
173
let entries =
176
-
List.filter_map (check_repo ~fs ~checkouts_path ~patch) repos_to_check
174
+
List.filter_map (check_repo ~sw ~fs ~checkouts_path ~patch) repos_to_check
177
175
|> List.flatten
178
176
in
179
177
{ entries; forks }
180
178
181
-
let show_commit ~proc ~fs ~config ~verse_config ~sha ?(refresh = false) () =
179
+
let show_commit ~sw ~proc ~fs ~config ~verse_config ~sha ?(refresh = false) () =
182
180
let checkouts_path = Config.Paths.checkouts config in
183
181
let forks =
184
-
Forks.compute ~proc ~fs ~verse_config ~monopam_config:config ~refresh ()
182
+
Forks.compute ~sw ~proc ~fs ~verse_config ~monopam_config:config ~refresh ()
185
183
in
186
184
List.find_map
187
185
(fun (r : Forks.repo_analysis) ->
188
186
let checkout_path = Fpath.(checkouts_path / r.repo_name) in
189
187
if not (Git.Repository.is_repo ~fs checkout_path) then None
190
188
else
191
-
let repo =
192
-
Eio.Switch.run @@ fun sw ->
193
-
Git.Repository.open_repo ~sw ~fs checkout_path
194
-
in
189
+
let repo = Git.Repository.open_repo ~sw ~fs checkout_path in
195
190
List.find_map
196
191
(fun (handle, _src, rel) ->
197
192
match rel with
···
240
235
| Skipped of string
241
236
| Failed of string * string
242
237
243
-
let pull_one_repo ~fs ~checkouts_path ~handle (r : Forks.repo_analysis) =
238
+
let pull_one_repo ~sw ~fs ~checkouts_path ~handle (r : Forks.repo_analysis) =
244
239
let handle_source =
245
240
List.find_opt (fun (h, _, _) -> h = handle) r.verse_sources
246
241
in
···
251
246
if not (Git.Repository.is_repo ~fs checkout_path) then
252
247
[ Skipped r.repo_name ]
253
248
else begin
254
-
let git_repo =
255
-
Eio.Switch.run @@ fun sw ->
256
-
Git.Repository.open_repo ~sw ~fs checkout_path
257
-
in
249
+
let git_repo = Git.Repository.open_repo ~sw ~fs checkout_path in
258
250
match rel with
259
251
| Forks.Same_url | Forks.Same_commit | Forks.I_am_ahead _
260
252
| Forks.Not_fetched | Forks.Unrelated ->
···
275
267
| Error (`Msg msg) -> [ Failed (r.repo_name, msg) ])
276
268
end
277
269
278
-
let pull_from_handle ~proc ~fs ~config ~verse_config ~handle ?repo
270
+
let pull_from_handle ~sw ~proc ~fs ~config ~verse_config ~handle ?repo
279
271
?(refresh = false) () =
280
272
let checkouts_path = Config.Paths.checkouts config in
281
273
let forks =
282
-
Forks.compute ~proc ~fs ~verse_config ~monopam_config:config ~refresh ()
274
+
Forks.compute ~sw ~proc ~fs ~verse_config ~monopam_config:config ~refresh ()
283
275
in
284
276
let repos_to_check =
285
277
match repo with
···
287
279
| Some name -> List.filter (fun r -> r.Forks.repo_name = name) forks.repos
288
280
in
289
281
let actions =
290
-
List.concat_map (pull_one_repo ~fs ~checkouts_path ~handle) repos_to_check
282
+
List.concat_map
283
+
(pull_one_repo ~sw ~fs ~checkouts_path ~handle)
284
+
repos_to_check
291
285
in
292
286
let repos_pulled, repos_skipped, repos_failed =
293
287
List.fold_left
···
306
300
307
301
(** {1 Cherry-pick} *)
308
302
309
-
let cherrypick ~proc ~fs ~config ~verse_config ~sha ?(refresh = false) () =
303
+
let cherrypick ~sw ~proc ~fs ~config ~verse_config ~sha ?(refresh = false) () =
310
304
let checkouts_path = Config.Paths.checkouts config in
311
-
match show_commit ~proc ~fs ~config ~verse_config ~sha ~refresh () with
305
+
match show_commit ~sw ~proc ~fs ~config ~verse_config ~sha ~refresh () with
312
306
| None ->
313
307
Error
314
308
(Ctx.Config_error (Fmt.str "Commit %s not found in any verse diff" sha))
···
319
313
(Ctx.Config_error
320
314
(Fmt.str "No checkout for repository %s" info.commit_repo))
321
315
else begin
322
-
let git_repo =
323
-
Eio.Switch.run @@ fun sw ->
324
-
Git.Repository.open_repo ~sw ~fs checkout_path
325
-
in
316
+
let git_repo = Git.Repository.open_repo ~sw ~fs checkout_path in
326
317
match Git.Repository.cherry_pick git_repo ~commit:info.commit_hash with
327
318
| Ok _new_hash ->
328
319
Ok
+4
lib/diff.mli
+4
lib/diff.mli
···
60
60
(** {1 Diff Operations} *)
61
61
62
62
val compute :
63
+
sw:Eio.Switch.t ->
63
64
proc:_ Eio.Process.mgr ->
64
65
fs:Eio.Fs.dir_ty Eio.Path.t ->
65
66
config:Config.t ->
···
73
74
and verse state. *)
74
75
75
76
val show_commit :
77
+
sw:Eio.Switch.t ->
76
78
proc:_ Eio.Process.mgr ->
77
79
fs:Eio.Fs.dir_ty Eio.Path.t ->
78
80
config:Config.t ->
···
87
89
(** {1 Pull from Handle} *)
88
90
89
91
val pull_from_handle :
92
+
sw:Eio.Switch.t ->
90
93
proc:_ Eio.Process.mgr ->
91
94
fs:Eio.Fs.dir_ty Eio.Path.t ->
92
95
config:Config.t ->
···
102
105
(** {1 Cherry-pick} *)
103
106
104
107
val cherrypick :
108
+
sw:Eio.Switch.t ->
105
109
proc:_ Eio.Process.mgr ->
106
110
fs:Eio.Fs.dir_ty Eio.Path.t ->
107
111
config:Config.t ->
+21
-30
lib/doctor.ml
+21
-30
lib/doctor.ml
···
368
368
(** Information about a single remote's status *)
369
369
370
370
(** Analyze a single remote for a checkout *)
371
-
let analyze_remote ~fs ~checkout_dir ~remote_name =
372
-
let repo =
373
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs checkout_dir
374
-
in
371
+
let analyze_remote ~sw ~fs ~checkout_dir ~remote_name =
372
+
let repo = Git.Repository.open_repo ~sw ~fs checkout_dir in
375
373
let url =
376
374
Git.Repository.remote_url repo remote_name
377
375
|> Option.value ~default:"(unknown)"
···
404
402
{ remote_name; url; behind; incoming_commits }
405
403
406
404
(** Analyze all remotes for a checkout *)
407
-
let analyze_checkout_remotes ~fs ~checkout_dir =
408
-
let repo =
409
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs checkout_dir
410
-
in
405
+
let analyze_checkout_remotes ~sw ~fs ~checkout_dir =
406
+
let repo = Git.Repository.open_repo ~sw ~fs checkout_dir in
411
407
let remotes = Git.Repository.list_remotes repo in
412
408
List.map
413
-
(fun remote_name -> analyze_remote ~fs ~checkout_dir ~remote_name)
409
+
(fun remote_name -> analyze_remote ~sw ~fs ~checkout_dir ~remote_name)
414
410
remotes
415
411
416
412
(** Strip ANSI escape codes from a string *)
···
808
804
(** {1 Main Analysis} *)
809
805
810
806
(** Check repos for dirty state, returning warnings *)
811
-
let check_dirty_repos ~fs ~config =
807
+
let check_dirty_repos ~sw ~fs ~config =
812
808
let warnings = ref [] in
813
809
let opam_repo = Config.Paths.opam_repo config in
814
810
if Git.Repository.is_repo ~fs opam_repo then begin
815
-
let repo =
816
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs opam_repo
817
-
in
811
+
let repo = Git.Repository.open_repo ~sw ~fs opam_repo in
818
812
if Git.Repository.is_dirty repo then
819
813
warnings := "opam-repo has uncommitted changes" :: !warnings
820
814
end;
821
815
let monorepo = Config.Paths.monorepo config in
822
816
if Git.Repository.is_repo ~fs monorepo then begin
823
-
let repo =
824
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs monorepo
825
-
in
817
+
let repo = Git.Repository.open_repo ~sw ~fs monorepo in
826
818
if Git.Repository.is_dirty repo then
827
819
warnings := "monorepo has uncommitted changes" :: !warnings
828
820
end;
···
897
889
(priority_order b.action_priority))
898
890
!recommendations
899
891
900
-
let compute_statuses ~fs ~config ?package () =
892
+
let compute_statuses ~sw ~fs ~config ?package () =
901
893
let packages =
902
894
match
903
895
Opam_repo.scan ~fs:(fs :> _ Eio.Path.t) (Config.Paths.opam_repo config)
···
905
897
| Ok pkgs -> pkgs
906
898
| Error _ -> []
907
899
in
908
-
let statuses = Status.compute_all ~fs ~config packages in
900
+
let statuses = Status.compute_all ~sw ~fs ~config packages in
909
901
match package with
910
902
| None -> statuses
911
903
| Some name ->
912
904
List.filter (fun (s : Status.t) -> Package.name s.package = name) statuses
913
905
914
-
let collect_remotes_by_repo ~fs ~config statuses =
906
+
let collect_remotes_by_repo ~sw ~fs ~config statuses =
915
907
let checkouts_root = Config.Paths.checkouts config in
916
908
List.filter_map
917
909
(fun (status : Status.t) ->
···
919
911
let checkout_dir = Fpath.(checkouts_root / name) in
920
912
match status.checkout with
921
913
| Status.Missing | Status.Not_a_repo -> None
922
-
| _ -> Some (name, analyze_checkout_remotes ~fs ~checkout_dir))
914
+
| _ -> Some (name, analyze_checkout_remotes ~sw ~fs ~checkout_dir))
923
915
statuses
924
916
925
917
let merge_claude_repos ~base_repos claude_repos =
···
930
922
| None -> base_repo)
931
923
base_repos
932
924
933
-
let analyze_incoming ~proc ~clock ~statuses ~remotes_by_repo ~base_repos
925
+
let analyze_incoming ~sw ~proc ~clock ~statuses ~remotes_by_repo ~base_repos
934
926
repos_with_incoming =
935
927
if repos_with_incoming <> [] then begin
936
928
Log.app (fun m ->
···
939
931
let status_summary = build_status_summary statuses in
940
932
let incoming_summary = build_incoming_summary remotes_by_repo in
941
933
match
942
-
Eio.Switch.run (fun sw ->
943
-
analyze_with_claude ~sw ~process_mgr:proc ~clock ~status_summary
944
-
~incoming_summary)
934
+
analyze_with_claude ~sw ~process_mgr:proc ~clock ~status_summary
935
+
~incoming_summary
945
936
with
946
937
| Some json ->
947
938
let claude_repos, recs, warns = parse_claude_response json in
···
975
966
repos_behind_upstream )
976
967
977
968
(** Run the doctor analysis *)
978
-
let analyze ~proc ~fs ~config ~verse_config ~clock ?package ?(no_sync = false)
979
-
() =
969
+
let analyze ~sw ~proc ~fs ~config ~verse_config ~clock ?package
970
+
?(no_sync = false) () =
980
971
let _ = no_sync in
981
972
let now = Eio.Time.now clock in
982
973
let now_ptime =
···
984
975
in
985
976
let timestamp = Ptime.to_rfc3339 now_ptime ~tz_offset_s:0 in
986
977
let workspace = Fpath.to_string (Verse_config.root verse_config) in
987
-
let statuses = compute_statuses ~fs ~config ?package () in
988
-
let warnings = check_dirty_repos ~fs ~config in
978
+
let statuses = compute_statuses ~sw ~fs ~config ?package () in
979
+
let warnings = check_dirty_repos ~sw ~fs ~config in
989
980
Log.app (fun m ->
990
981
m "Analyzing remotes for %d repositories..." (List.length statuses));
991
-
let remotes_by_repo = collect_remotes_by_repo ~fs ~config statuses in
982
+
let remotes_by_repo = collect_remotes_by_repo ~sw ~fs ~config statuses in
992
983
let repos_with_incoming =
993
984
List.filter
994
985
(fun (_name, remotes) -> List.exists (fun r -> r.behind > 0) remotes)
···
996
987
in
997
988
let base_repos = build_base_repos statuses in
998
989
let repos, claude_recommendations, claude_warnings =
999
-
analyze_incoming ~proc ~clock ~statuses ~remotes_by_repo ~base_repos
990
+
analyze_incoming ~sw ~proc ~clock ~statuses ~remotes_by_repo ~base_repos
1000
991
repos_with_incoming
1001
992
in
1002
993
let report_summary, repos_need_sync, repos_behind_upstream =
+9
-8
lib/doctor.mli
+9
-8
lib/doctor.mli
···
10
10
11
11
Run the doctor analysis:
12
12
{[
13
-
Eio_main.run @@ fun env ->
14
-
let fs = Eio.Stdenv.fs env in
15
-
let proc = Eio.Stdenv.process_mgr env in
16
-
let clock = Eio.Stdenv.clock env in
17
-
let report = Doctor.analyze ~proc ~fs ~config ~verse_config ~clock () in
18
-
Fmt.pr "%a@." Doctor.pp_report report
13
+
Eio_main.run @@ fun env ->
14
+
let fs = Eio.Stdenv.fs env in
15
+
let proc = Eio.Stdenv.process_mgr env in
16
+
let clock = Eio.Stdenv.clock env in
17
+
let report = Doctor.analyze ~proc ~fs ~config ~verse_config ~clock () in
18
+
Fmt.pr "%a@." Doctor.pp_report report
19
19
]}
20
20
21
21
Or output as JSON:
22
22
{[
23
-
let json = Doctor.to_json report in
24
-
print_endline json
23
+
let json = Doctor.to_json report in
24
+
print_endline json
25
25
]} *)
26
26
27
27
(** {1 Types} *)
···
139
139
(** {1 Analysis} *)
140
140
141
141
val analyze :
142
+
sw:Eio.Switch.t ->
142
143
proc:_ Eio.Process.mgr ->
143
144
fs:Eio.Fs.dir_ty Eio.Path.t ->
144
145
config:Config.t ->
+3
-3
lib/dune_project.ml
+3
-3
lib/dune_project.ml
···
99
99
let in_string = ref false in
100
100
while !i < len do
101
101
let c = content.[!i] in
102
-
if !in_string then begin
103
-
if c = '\\' && !i + 1 < len then begin
102
+
if !in_string then
103
+
begin if c = '\\' && !i + 1 < len then begin
104
104
let next = content.[!i + 1] in
105
105
if next = '\n' then begin
106
106
(* Continuation: skip \ \n and leading whitespace *)
···
120
120
Buffer.add_char buf c;
121
121
incr i
122
122
end
123
-
end
123
+
end
124
124
else begin
125
125
if c = '"' then in_string := true
126
126
else if c = ';' then begin
+6
-12
lib/feature.ml
+6
-12
lib/feature.ml
···
43
43
(* Get the feature worktree path: root/work/<name> *)
44
44
let path config name = Fpath.(work_path config / name)
45
45
46
-
let add ~fs ~config ~name () =
46
+
let add ~sw ~fs ~config ~name () =
47
47
let mono = Verse_config.mono_path config in
48
48
let work_dir = work_path config in
49
49
let wt_path = path config name in
50
-
let repo =
51
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs mono
52
-
in
50
+
let repo = Git.Repository.open_repo ~sw ~fs mono in
53
51
let wt = Git.Repository.worktree repo in
54
52
(* Check if feature already exists *)
55
53
if Git.Worktree.exists wt ~path:wt_path then Error (Feature_exists name)
···
66
64
| Ok () -> Ok { name; path = wt_path; branch = name })
67
65
end
68
66
69
-
let remove ~fs ~config ~name ~force () =
67
+
let remove ~sw ~fs ~config ~name ~force () =
70
68
let mono = Verse_config.mono_path config in
71
69
let wt_path = path config name in
72
-
let repo =
73
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs mono
74
-
in
70
+
let repo = Git.Repository.open_repo ~sw ~fs mono in
75
71
let wt = Git.Repository.worktree repo in
76
72
(* Check if feature exists *)
77
73
if not (Git.Worktree.exists wt ~path:wt_path) then
···
81
77
| Error (`Msg msg) -> Error (Config_error msg)
82
78
| Ok () -> Ok ()
83
79
84
-
let list ~fs ~config () =
80
+
let list ~sw ~fs ~config () =
85
81
let mono = Verse_config.mono_path config in
86
82
let work_dir = work_path config in
87
-
let repo =
88
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs mono
89
-
in
83
+
let repo = Git.Repository.open_repo ~sw ~fs mono in
90
84
let wt = Git.Repository.worktree repo in
91
85
let all_worktrees =
92
86
Git.Worktree.list wt ~head:(Git.Repository.head repo)
+7
-1
lib/feature.mli
+7
-1
lib/feature.mli
···
31
31
(** {1 Operations} *)
32
32
33
33
val add :
34
+
sw:Eio.Switch.t ->
34
35
fs:Eio.Fs.dir_ty Eio.Path.t ->
35
36
config:Verse_config.t ->
36
37
name:string ->
···
45
46
@param name Feature name (used for both directory and branch). *)
46
47
47
48
val remove :
49
+
sw:Eio.Switch.t ->
48
50
fs:Eio.Fs.dir_ty Eio.Path.t ->
49
51
config:Verse_config.t ->
50
52
name:string ->
···
61
63
@param force If true, remove even with uncommitted changes. *)
62
64
63
65
val list :
64
-
fs:Eio.Fs.dir_ty Eio.Path.t -> config:Verse_config.t -> unit -> entry list
66
+
sw:Eio.Switch.t ->
67
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
68
+
config:Verse_config.t ->
69
+
unit ->
70
+
entry list
65
71
(** [list ~fs ~config ()] returns all feature worktrees.
66
72
67
73
Only returns worktrees in the [root/work/] directory.
+43
-75
lib/fork_join.ml
+43
-75
lib/fork_join.ml
···
386
386
(** {2 Fork Plan Helpers} *)
387
387
388
388
(** Gather discovery info for fork. *)
389
-
let fork_discovery ~fs ~monorepo ~prefix ~subtree_path ~src_path =
389
+
let fork_discovery ~sw ~fs ~monorepo ~prefix ~subtree_path ~src_path =
390
390
let mono_exists = is_directory ~fs Fpath.(monorepo / prefix) in
391
391
let src_exists = is_directory ~fs src_path in
392
392
let has_subtree_hist =
393
393
if mono_exists then
394
-
let repo =
395
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs monorepo
396
-
in
394
+
let repo = Git.Repository.open_repo ~sw ~fs monorepo in
397
395
Git.Repository.has_subtree_history repo ~prefix
398
396
else false
399
397
in
···
492
490
subtree from src/<name>/
493
491
494
492
This ensures the subtree relationship is properly established for sync. *)
495
-
let plan_fork ~proc ~fs ~config ~name ?push_url ?(dry_run = false) () =
493
+
let plan_fork ~sw ~proc ~fs ~config ~name ?push_url ?(dry_run = false) () =
496
494
let monorepo = Verse_config.mono_path config in
497
495
let checkouts = Verse_config.src_path config in
498
496
let prefix = name in
···
502
500
let handle = Verse_config.handle config in
503
501
504
502
let discovery, has_subtree_hist, files =
505
-
fork_discovery ~fs ~monorepo ~prefix ~subtree_path ~src_path
503
+
fork_discovery ~sw ~fs ~monorepo ~prefix ~subtree_path ~src_path
506
504
in
507
505
508
506
if not discovery.mono_exists then Error (Subtree_not_found name)
···
747
745
(** {2 Action Execution Helpers} *)
748
746
749
747
(** Execute git config action. *)
750
-
let exec_git_config ~fs ~repo ~key ~value =
751
-
let git_repo =
752
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs repo
753
-
in
748
+
let exec_git_config ~sw ~fs ~repo ~key ~value =
749
+
let git_repo = Git.Repository.open_repo ~sw ~fs repo in
754
750
let config =
755
751
match Git.Repository.read_config git_repo with
756
752
| Some c -> c
···
766
762
Ok ()
767
763
768
764
(** Execute subtree split action. *)
769
-
let exec_subtree_split ~fs ~state ~repo ~prefix =
770
-
let git_repo =
771
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs repo
772
-
in
765
+
let exec_subtree_split ~sw ~fs ~state ~repo ~prefix =
766
+
let git_repo = Git.Repository.open_repo ~sw ~fs repo in
773
767
match Git.Repository.read_ref git_repo "HEAD" with
774
768
| None -> Error (Git_error (Git_cli.Io_error "no HEAD ref found"))
775
769
| Some head -> (
···
781
775
Ok ())
782
776
783
777
(** Execute subtree add action. *)
784
-
let exec_subtree_add ~proc ~fs ~repo ~prefix ~url ~branch =
778
+
let exec_subtree_add ~sw ~proc ~fs ~repo ~prefix ~url ~branch =
785
779
match Git_cli.fetch_url ~proc ~fs ~repo ~url ~branch () with
786
780
| Error e -> Error (Git_error e)
787
781
| Ok hash_hex -> (
788
-
let git_repo =
789
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs repo
790
-
in
782
+
let git_repo = Git.Repository.open_repo ~sw ~fs repo in
791
783
let commit = Git.Hash.of_hex hash_hex in
792
784
let user =
793
785
match Git_cli.global_git_user ~fs () with
···
830
822
Error (Config_error (Fmt.str "Failed to update sources.toml: %s" msg))
831
823
832
824
(** Execute a single action *)
833
-
let execute_action ~proc ~fs ~state action =
825
+
let execute_action ~sw ~proc ~fs ~state action =
834
826
match action with
835
827
| Check_remote_exists _url -> Ok ()
836
828
| Create_directory path ->
837
829
ensure_dir ~fs path;
838
830
Ok ()
839
831
| Git_init path ->
840
-
let (_ : Git.Repository.t) =
841
-
Eio.Switch.run @@ fun sw -> Git.Repository.init ~sw ~fs path
842
-
in
832
+
let (_ : Git.Repository.t) = Git.Repository.init ~sw ~fs path in
843
833
Ok ()
844
-
| Git_config { repo; key; value } -> exec_git_config ~fs ~repo ~key ~value
834
+
| Git_config { repo; key; value } -> exec_git_config ~sw ~fs ~repo ~key ~value
845
835
| Git_clone { url; dest; branch } ->
846
836
Git_cli.clone ~proc ~fs ~url ~branch dest
847
837
|> Result.map_error (fun e -> Git_error e)
848
838
| Git_subtree_split { repo; prefix } ->
849
-
exec_subtree_split ~fs ~state ~repo ~prefix
839
+
exec_subtree_split ~sw ~fs ~state ~repo ~prefix
850
840
| Git_subtree_add { repo; prefix; url; branch } ->
851
-
exec_subtree_add ~proc ~fs ~repo ~prefix ~url ~branch
841
+
exec_subtree_add ~sw ~proc ~fs ~repo ~prefix ~url ~branch
852
842
| Git_add_remote { repo; name; url } ->
853
-
let git_repo =
854
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs repo
855
-
in
843
+
let git_repo = Git.Repository.open_repo ~sw ~fs repo in
856
844
Git.Repository.add_remote git_repo ~name ~url ()
857
845
|> Result.map_error (fun (`Msg msg) -> Git_error (Git_cli.Io_error msg))
858
846
| Git_push_ref { repo; target; ref_spec } ->
···
860
848
Git_cli.push_ref ~proc ~fs ~repo ~target ~ref_spec ()
861
849
|> Result.map_error (fun e -> Git_error e)
862
850
| Git_checkout { repo; branch } ->
863
-
let git_repo =
864
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs repo
865
-
in
851
+
let git_repo = Git.Repository.open_repo ~sw ~fs repo in
866
852
Git.Repository.checkout_ref git_repo branch
867
853
|> Result.map_error (fun (`Msg msg) -> Git_error (Git_cli.Io_error msg))
868
854
| Git_branch_rename { repo; new_name } ->
869
-
let git_repo =
870
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs repo
871
-
in
855
+
let git_repo = Git.Repository.open_repo ~sw ~fs repo in
872
856
Git.Repository.rename_branch git_repo ~new_name
873
857
|> Result.map_error (fun (`Msg msg) -> Git_error (Git_cli.Io_error msg))
874
858
| Copy_directory { src; dest } ->
875
859
copy_directory ~fs ~src ~dest;
876
860
Ok ()
877
861
| Git_add_all path ->
878
-
let git_repo =
879
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs path
880
-
in
862
+
let git_repo = Git.Repository.open_repo ~sw ~fs path in
881
863
Git.Repository.add_all git_repo
882
864
|> Result.map_error (fun (`Msg msg) -> Git_error (Git_cli.Io_error msg))
883
865
| Git_commit { repo; message } ->
884
-
let git_repo =
885
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs repo
886
-
in
866
+
let git_repo = Git.Repository.open_repo ~sw ~fs repo in
887
867
Git.Repository.commit git_repo ~message
888
868
|> Result.map (fun _ -> ())
889
869
|> Result.map_error (fun (`Msg msg) -> Git_error (Git_cli.Io_error msg))
890
870
| Git_rm { repo; path; recursive } ->
891
-
let git_repo =
892
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs repo
893
-
in
871
+
let git_repo = Git.Repository.open_repo ~sw ~fs repo in
894
872
Git.Repository.rm git_repo ~recursive path
895
873
|> Result.map_error (fun (`Msg msg) -> Git_error (Git_cli.Io_error msg))
896
874
| Update_sources_toml { path; name; entry } ->
897
875
exec_update_sources ~fs ~path ~name ~entry
898
876
899
877
(** Execute a complete fork action plan *)
900
-
let execute_fork_plan ~proc ~fs plan =
878
+
let execute_fork_plan ~sw ~proc ~fs plan =
901
879
if plan.dry_run then Ok plan.result
902
880
else begin
903
881
let state = { split_commit = None } in
904
882
let rec run_actions = function
905
883
| [] -> Ok ()
906
884
| action :: rest -> (
907
-
match execute_action ~proc ~fs ~state action with
885
+
match execute_action ~sw ~proc ~fs ~state action with
908
886
| Error e -> Error e
909
887
| Ok () -> run_actions rest)
910
888
in
···
921
899
end
922
900
923
901
(** Execute a complete join action plan *)
924
-
let execute_join_plan ~proc ~fs plan =
902
+
let execute_join_plan ~sw ~proc ~fs plan =
925
903
if plan.dry_run then Ok plan.result
926
904
else begin
927
905
let state = { split_commit = None } in
928
906
let rec run_actions = function
929
907
| [] -> Ok ()
930
908
| action :: rest -> (
931
-
match execute_action ~proc ~fs ~state action with
909
+
match execute_action ~sw ~proc ~fs ~state action with
932
910
| Error e -> Error e
933
911
| Ok () -> run_actions rest)
934
912
in
···
969
947
Logs.warn (fun m -> m "Failed to update sources.toml: %s" msg))
970
948
| None -> ()
971
949
972
-
let fork_add_push_remote ~fs ~src_path ~push_url =
973
-
let checkout_repo =
974
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs src_path
975
-
in
950
+
let fork_add_push_remote ~sw ~fs ~src_path ~push_url =
951
+
let checkout_repo = Git.Repository.open_repo ~sw ~fs src_path in
976
952
match push_url with
977
953
| Some url ->
978
954
Git.Repository.add_remote checkout_repo ~name:"origin" ~url ()
979
955
|> Result.map_error (fun (`Msg msg) -> Git_error (Git_cli.Io_error msg))
980
956
| None -> Ok ()
981
957
982
-
let fork_init_and_push ~proc ~fs ~monorepo ~checkouts ~src_path ~split_commit =
958
+
let fork_init_and_push ~sw ~proc ~fs ~monorepo ~checkouts ~src_path
959
+
~split_commit =
983
960
ensure_dir ~fs checkouts;
984
-
let git_repo =
985
-
Eio.Switch.run @@ fun sw -> Git.Repository.init ~sw ~fs src_path
986
-
in
961
+
let git_repo = Git.Repository.init ~sw ~fs src_path in
987
962
let mono_str = Fpath.to_string monorepo in
988
963
match Git.Repository.add_remote git_repo ~name:"mono" ~url:mono_str () with
989
964
| Error (`Msg msg) -> Error (Git_error (Git_cli.Io_error msg))
···
995
970
with
996
971
| Error e -> Error (Git_error e)
997
972
| Ok () ->
998
-
let checkout_repo =
999
-
Eio.Switch.run @@ fun sw ->
1000
-
Git.Repository.open_repo ~sw ~fs src_path
1001
-
in
973
+
let checkout_repo = Git.Repository.open_repo ~sw ~fs src_path in
1002
974
Git.Repository.checkout_ref checkout_repo "main"
1003
975
|> Result.map_error (fun (`Msg msg) ->
1004
976
Git_error (Git_cli.Io_error msg)))
1005
977
1006
-
let fork ~proc ~fs ~config ~name ?push_url ?(dry_run = false) () =
978
+
let fork ~sw ~proc ~fs ~config ~name ?push_url ?(dry_run = false) () =
1007
979
let monorepo = Verse_config.mono_path config in
1008
980
let checkouts = Verse_config.src_path config in
1009
981
let prefix = name in
···
1025
997
packages_created = packages;
1026
998
}
1027
999
else begin
1028
-
let git_repo =
1029
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs monorepo
1030
-
in
1000
+
let git_repo = Git.Repository.open_repo ~sw ~fs monorepo in
1031
1001
match Git.Repository.read_ref git_repo "HEAD" with
1032
1002
| None -> Error (Git_error (Git_cli.Io_error "no HEAD ref found"))
1033
1003
| Some head -> (
···
1037
1007
| Ok (Some split_hash) -> (
1038
1008
let split_commit = Git.Hash.to_hex split_hash in
1039
1009
match
1040
-
fork_init_and_push ~proc ~fs ~monorepo ~checkouts ~src_path
1010
+
fork_init_and_push ~sw ~proc ~fs ~monorepo ~checkouts ~src_path
1041
1011
~split_commit
1042
1012
with
1043
1013
| Error _ as e -> e
1044
1014
| Ok () -> (
1045
-
match fork_add_push_remote ~fs ~src_path ~push_url with
1015
+
match fork_add_push_remote ~sw ~fs ~src_path ~push_url with
1046
1016
| Error _ as e -> e
1047
1017
| Ok () ->
1048
1018
fork_update_sources ~fs ~monorepo ~name ~push_url;
···
1087
1057
Logs.warn (fun m -> m "Failed to update sources.toml: %s" msg))
1088
1058
| None -> ()
1089
1059
1090
-
let join_add_subtree ~proc ~fs ~monorepo ~prefix ~url ~branch =
1060
+
let join_add_subtree ~sw ~proc ~fs ~monorepo ~prefix ~url ~branch =
1091
1061
match Git_cli.fetch_url ~proc ~fs ~repo:monorepo ~url ~branch () with
1092
1062
| Error e -> Error (Git_error e)
1093
1063
| Ok hash_hex ->
1094
-
let git_repo =
1095
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs monorepo
1096
-
in
1064
+
let git_repo = Git.Repository.open_repo ~sw ~fs monorepo in
1097
1065
let commit = Git.Hash.of_hex hash_hex in
1098
1066
let user =
1099
1067
match Git_cli.global_git_user ~fs () with
···
1110
1078
~message ()
1111
1079
|> Result.map_error (fun (`Msg msg) -> Git_error (Git_cli.Io_error msg))
1112
1080
1113
-
let join ~proc ~fs ~config ~url ?name ?upstream ?(dry_run = false) () =
1081
+
let join ~sw ~proc ~fs ~config ~url ?name ?upstream ?(dry_run = false) () =
1114
1082
let name = match name with Some n -> n | None -> name_from_url url in
1115
1083
let monorepo = Verse_config.mono_path config in
1116
1084
let checkouts = Verse_config.src_path config in
···
1134
1102
match Git_cli.clone ~proc ~fs ~url ~branch src_path with
1135
1103
| Error e -> Error (Git_error e)
1136
1104
| Ok () -> (
1137
-
match join_add_subtree ~proc ~fs ~monorepo ~prefix ~url ~branch with
1105
+
match join_add_subtree ~sw ~proc ~fs ~monorepo ~prefix ~url ~branch with
1138
1106
| Error _ as e -> e
1139
1107
| Ok _ ->
1140
1108
let packages = opam_files ~fs subtree_path in
···
1149
1117
})
1150
1118
end
1151
1119
1152
-
let join_from_verse ~proc ~fs ~config ~verse_config ~package ~handle ~fork_url
1153
-
?(dry_run = false) () =
1120
+
let join_from_verse ~sw ~proc ~fs ~config ~verse_config ~package ~handle
1121
+
~fork_url ?(dry_run = false) () =
1154
1122
(* First use verse fork to set up the opam entries *)
1155
1123
match
1156
-
Verse.fork ~proc ~fs ~config:verse_config ~handle ~package ~fork_url
1124
+
Verse.fork ~sw ~proc ~fs ~config:verse_config ~handle ~package ~fork_url
1157
1125
~dry_run ()
1158
1126
with
1159
1127
| Error e -> Error (Verse_error e)
···
1171
1139
(* Now join the repository *)
1172
1140
let name = fork_result.subtree_name in
1173
1141
match
1174
-
join ~proc ~fs ~config ~url:fork_url ~name
1142
+
join ~sw ~proc ~fs ~config ~url:fork_url ~name
1175
1143
~upstream:fork_result.upstream_url ~dry_run ()
1176
1144
with
1177
1145
| Error e -> Error e
+6
lib/fork_join.mli
+6
lib/fork_join.mli
···
137
137
(** {1 Plan Builders} *)
138
138
139
139
val plan_fork :
140
+
sw:Eio.Switch.t ->
140
141
proc:_ Eio.Process.mgr ->
141
142
fs:Eio.Fs.dir_ty Eio.Path.t ->
142
143
config:Verse_config.t ->
···
210
211
(** {1 Plan Execution} *)
211
212
212
213
val execute_fork_plan :
214
+
sw:Eio.Switch.t ->
213
215
proc:_ Eio.Process.mgr ->
214
216
fs:Eio.Fs.dir_ty Eio.Path.t ->
215
217
fork_result action_plan ->
···
221
223
actions. *)
222
224
223
225
val execute_join_plan :
226
+
sw:Eio.Switch.t ->
224
227
proc:_ Eio.Process.mgr ->
225
228
fs:Eio.Fs.dir_ty Eio.Path.t ->
226
229
join_result action_plan ->
···
233
236
(** {1 Fork Operations} *)
234
237
235
238
val fork :
239
+
sw:Eio.Switch.t ->
236
240
proc:_ Eio.Process.mgr ->
237
241
fs:Eio.Fs.dir_ty Eio.Path.t ->
238
242
config:Verse_config.t ->
···
257
261
(** {1 Join Operations} *)
258
262
259
263
val join :
264
+
sw:Eio.Switch.t ->
260
265
proc:_ Eio.Process.mgr ->
261
266
fs:Eio.Fs.dir_ty Eio.Path.t ->
262
267
config:Verse_config.t ->
···
281
286
@param dry_run If true, validate and report what would be done. *)
282
287
283
288
val join_from_verse :
289
+
sw:Eio.Switch.t ->
284
290
proc:_ Eio.Process.mgr ->
285
291
fs:Eio.Fs.dir_ty Eio.Path.t ->
286
292
config:Verse_config.t ->
+21
-28
lib/forks.ml
+21
-28
lib/forks.ml
···
581
581
let verse_remote_name handle = "verse/" ^ handle
582
582
583
583
(** Check if a remote exists *)
584
-
let remote_exists ~proc:_ ~fs ~repo remote_name =
585
-
let git_repo =
586
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs repo
587
-
in
584
+
let remote_exists ~sw ~proc:_ ~fs ~repo remote_name =
585
+
let git_repo = Git.Repository.open_repo ~sw ~fs repo in
588
586
match Git.Repository.remote_url git_repo remote_name with
589
587
| Some _ -> true
590
588
| None -> false
591
589
592
590
(** Add a git remote *)
593
-
let add_remote ~proc:_ ~fs ~repo ~name ~url () =
594
-
let git_repo =
595
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs repo
596
-
in
591
+
let add_remote ~sw ~proc:_ ~fs ~repo ~name ~url () =
592
+
let git_repo = Git.Repository.open_repo ~sw ~fs repo in
597
593
Log.debug (fun m ->
598
594
m "Adding remote %s -> %a (in %a)" name Uri.pp url Fpath.pp repo);
599
595
Git.Repository.add_remote git_repo ~name ~url:(Uri.to_string url) ()
···
627
623
end
628
624
629
625
(** Get the commit hash for a ref *)
630
-
let ref_commit ~fs ~repo ref_name =
631
-
let git_repo =
632
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs repo
633
-
in
626
+
let ref_commit ~sw ~fs ~repo ref_name =
627
+
let git_repo = Git.Repository.open_repo ~sw ~fs repo in
634
628
(* Handle refs like "origin/main" or "verse/handle/main" *)
635
629
let ref_path =
636
630
if String.contains ref_name '/' then "refs/remotes/" ^ ref_name
···
641
635
| None -> Git.Repository.read_ref git_repo ref_name
642
636
643
637
(** Compare two refs and determine relationship *)
644
-
let compare_refs ~fs ~repo ~my_ref ~their_ref () =
645
-
let my_commit = ref_commit ~fs ~repo my_ref in
646
-
let their_commit = ref_commit ~fs ~repo their_ref in
638
+
let compare_refs ~sw ~fs ~repo ~my_ref ~their_ref () =
639
+
let my_commit = ref_commit ~sw ~fs ~repo my_ref in
640
+
let their_commit = ref_commit ~sw ~fs ~repo their_ref in
647
641
match (my_commit, their_commit) with
648
642
| None, _ | _, None -> Not_fetched
649
643
| Some my_hash, Some their_hash when Git.Hash.equal my_hash their_hash ->
650
644
Same_commit
651
645
| Some my_hash, Some their_hash -> (
652
-
let git_repo =
653
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs repo
654
-
in
646
+
let git_repo = Git.Repository.open_repo ~sw ~fs repo in
655
647
let my_is_ancestor =
656
648
Git.Rev_list.is_ancestor git_repo ~ancestor:my_hash
657
649
~descendant:their_hash
···
694
686
their_ahead;
695
687
}))
696
688
697
-
let compute_source_rel ~proc ~fs ~my_source ~checkout_path ~have_checkout
689
+
let compute_source_rel ~sw ~proc ~fs ~my_source ~checkout_path ~have_checkout
698
690
~refresh src =
699
691
let rel =
700
692
match my_source with
···
702
694
| _ when not have_checkout -> Not_fetched
703
695
| _ -> (
704
696
let remote_name = verse_remote_name src.handle in
705
-
if not (remote_exists ~proc ~fs ~repo:checkout_path remote_name) then begin
697
+
if not (remote_exists ~sw ~proc ~fs ~repo:checkout_path remote_name)
698
+
then begin
706
699
Log.info (fun m ->
707
700
m "Adding remote %s -> %a" remote_name Uri.pp src.url);
708
701
ignore
709
-
(add_remote ~proc ~fs ~repo:checkout_path ~name:remote_name
702
+
(add_remote ~sw ~proc ~fs ~repo:checkout_path ~name:remote_name
710
703
~url:src.url ())
711
704
end;
712
705
match
···
717
710
| Ok () ->
718
711
let my_ref = "origin/main" in
719
712
let their_ref = remote_name ^ "/main" in
720
-
compare_refs ~fs ~repo:checkout_path ~my_ref ~their_ref ())
713
+
compare_refs ~sw ~fs ~repo:checkout_path ~my_ref ~their_ref ())
721
714
in
722
715
(src.handle, src, rel)
723
716
724
-
let analyze_repo ~proc ~fs ~checkouts_path ~refresh ~my_repos ~verse_repos
717
+
let analyze_repo ~sw ~proc ~fs ~checkouts_path ~refresh ~my_repos ~verse_repos
725
718
repo_name acc =
726
719
let my_source =
727
720
match Hashtbl.find_opt my_repos repo_name with
···
739
732
let have_checkout = Git.Repository.is_repo ~fs checkout_path in
740
733
let verse_with_rel =
741
734
List.map
742
-
(compute_source_rel ~proc ~fs ~my_source ~checkout_path ~have_checkout
743
-
~refresh)
735
+
(compute_source_rel ~sw ~proc ~fs ~my_source ~checkout_path
736
+
~have_checkout ~refresh)
744
737
verse_sources
745
738
in
746
739
{ repo_name; my_source; verse_sources = verse_with_rel } :: acc
747
740
end
748
741
749
742
(** Compute fork analysis for all repos *)
750
-
let compute ~proc ~fs ~verse_config ~monopam_config ?(refresh = false) () =
743
+
let compute ~sw ~proc ~fs ~verse_config ~monopam_config ?(refresh = false) () =
751
744
let verse_path = Verse_config.verse_path verse_config in
752
745
let opam_repo_path = Config.Paths.opam_repo monopam_config in
753
746
let checkouts_path = Config.Paths.checkouts monopam_config in
···
763
756
let analyses =
764
757
Hashtbl.fold
765
758
(fun repo_name () acc ->
766
-
analyze_repo ~proc ~fs ~checkouts_path ~refresh ~my_repos ~verse_repos
767
-
repo_name acc)
759
+
analyze_repo ~sw ~proc ~fs ~checkouts_path ~refresh ~my_repos
760
+
~verse_repos repo_name acc)
768
761
all_repos []
769
762
in
770
763
let repos =
+1
lib/forks.mli
+1
lib/forks.mli
+13
-19
lib/import.ml
+13
-19
lib/import.ml
···
90
90
()
91
91
92
92
(** Commit staged changes using ocaml-git with fallback user *)
93
-
let git_commit ~fs ~target ~message =
94
-
let git_repo =
95
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs target
96
-
in
93
+
let git_commit ~sw ~fs ~target ~message =
94
+
let git_repo = Git.Repository.open_repo ~sw ~fs target in
97
95
let user = git_user ~fs () in
98
96
Git.Repository.commit_index git_repo ~author:user ~committer:user ~message ()
99
97
100
98
(** {1 Import Operations} *)
101
99
102
100
(** Import a single git URL as a subtree *)
103
-
let git_url ~proc ~fs ~target ~url ~branch ~ref_ ~name ~dry_run =
101
+
let git_url ~sw ~proc ~fs ~target ~url ~branch ~ref_ ~name ~dry_run =
104
102
let name = match name with Some n -> n | None -> repo_name_from_url url in
105
103
let url = normalize_url url in
106
104
let prefix_path = Fpath.(target / name) in
···
125
123
with
126
124
| Error e -> err_git_fetch_failed e
127
125
| Ok hash_hex -> (
128
-
let git_repo =
129
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs target
130
-
in
126
+
let git_repo = Git.Repository.open_repo ~sw ~fs target in
131
127
let commit = Git.Hash.of_hex hash_hex in
132
128
let user = git_user ~fs () in
133
129
let message =
···
153
149
end
154
150
155
151
(** Import all entries from a lock file *)
156
-
let from_lock ~proc ~fs ~target ~lock_path ~dry_run =
152
+
let from_lock ~sw ~proc ~fs ~target ~lock_path ~dry_run =
157
153
let lock_dir = Fpath.parent lock_path in
158
154
match Mono_lock.load ~fs lock_dir with
159
155
| Error e -> Error e
···
168
164
List.map
169
165
(fun (name, entry) ->
170
166
let result =
171
-
git_url ~proc ~fs ~target ~url:entry.Mono_lock.url ~branch:None
172
-
~ref_:(Some entry.Mono_lock.ref_) ~name:(Some name) ~dry_run
167
+
git_url ~sw ~proc ~fs ~target ~url:entry.Mono_lock.url
168
+
~branch:None ~ref_:(Some entry.Mono_lock.ref_)
169
+
~name:(Some name) ~dry_run
173
170
in
174
171
(name, result))
175
172
imports
···
281
278
end
282
279
283
280
(** Main import function *)
284
-
let run ~proc ~fs ~target ~source ~name ~dry_run () =
281
+
let run ~sw ~proc ~fs ~target ~source ~name ~dry_run () =
285
282
match source with
286
283
| Git_url { url; branch; ref_ } -> (
287
-
match git_url ~proc ~fs ~target ~url ~branch ~ref_ ~name ~dry_run with
284
+
match git_url ~sw ~proc ~fs ~target ~url ~branch ~ref_ ~name ~dry_run with
288
285
| Error e -> Error e
289
286
| Ok result ->
290
287
(* Update sources.toml with source and pinned ref *)
···
312
309
in
313
310
match Sources_registry.save ~fs sources_path sources with
314
311
| Ok () -> (
315
-
let git_repo =
316
-
Eio.Switch.run @@ fun sw ->
317
-
Git.Repository.open_repo ~sw ~fs target
318
-
in
312
+
let git_repo = Git.Repository.open_repo ~sw ~fs target in
319
313
match
320
314
Git.Repository.add_to_index git_repo [ "sources.toml" ]
321
315
with
···
323
317
let msg =
324
318
Fmt.str "Update sources.toml: add %s" result.name
325
319
in
326
-
match git_commit ~fs ~target ~message:msg with
320
+
match git_commit ~sw ~fs ~target ~message:msg with
327
321
| Ok _ -> ()
328
322
| Error (`Msg e) ->
329
323
Log.warn (fun m ->
···
336
330
(* Update dune-project with external deps from all subtrees *)
337
331
if not dry_run then update_root_deps ~fs ~target;
338
332
Ok [ result ])
339
-
| Lock_file path -> from_lock ~proc ~fs ~target ~lock_path:path ~dry_run
333
+
| Lock_file path -> from_lock ~sw ~proc ~fs ~target ~lock_path:path ~dry_run
+2
lib/import.mli
+2
lib/import.mli
···
27
27
(** {1 Import Operations} *)
28
28
29
29
val run :
30
+
sw:Eio.Switch.t ->
30
31
proc:_ Eio.Process.mgr ->
31
32
fs:Eio.Fs.dir_ty Eio.Path.t ->
32
33
target:Fpath.t ->
···
45
46
Returns the list of imported subtrees, or an error message. *)
46
47
47
48
val git_url :
49
+
sw:Eio.Switch.t ->
48
50
proc:_ Eio.Process.mgr ->
49
51
fs:Eio.Fs.dir_ty Eio.Path.t ->
50
52
target:Fpath.t ->
+5
-9
lib/init.ml
+5
-9
lib/init.ml
···
313
313
314
314
(** {1 Monorepo Initialization} *)
315
315
316
-
let setup_and_commit ~fs ~monorepo ~monorepo_eio =
316
+
let setup_and_commit ~sw ~fs ~monorepo ~monorepo_eio =
317
317
Log.info (fun m -> m "Initializing monorepo at %a" Fpath.pp monorepo);
318
-
let (_ : Git.Repository.t) =
319
-
Eio.Switch.run @@ fun sw -> Git.Repository.init ~sw ~fs monorepo
320
-
in
318
+
let (_ : Git.Repository.t) = Git.Repository.init ~sw ~fs monorepo in
321
319
let dune_project = Eio.Path.(monorepo_eio / "dune-project") in
322
320
Log.debug (fun m -> m "Creating dune-project file");
323
321
Eio.Path.save ~create:(`Or_truncate 0o644) dune_project "(lang dune 3.20)\n";
···
328
326
Log.debug (fun m -> m "Creating .gitignore");
329
327
Eio.Path.save ~create:(`Or_truncate 0o644) gitignore gitignore_content;
330
328
Log.debug (fun m -> m "Staging and committing initial files");
331
-
let repo =
332
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs monorepo
333
-
in
329
+
let repo = Git.Repository.open_repo ~sw ~fs monorepo in
334
330
Result.bind
335
331
(Git.Repository.add_to_index repo
336
332
[ "dune-project"; "CLAUDE.md"; ".gitignore" ]
···
376
372
ignore (Eio.Process.await child))
377
373
end
378
374
379
-
let ensure ~proc ~fs ~config =
375
+
let ensure ~sw ~proc ~fs ~config =
380
376
let monorepo = Config.Paths.monorepo config in
381
377
let monorepo_eio = Eio.Path.(fs / Fpath.to_string monorepo) in
382
378
let is_directory =
···
399
395
Log.debug (fun m -> m "Creating monorepo directory %a" Fpath.pp monorepo);
400
396
Ctx.mkdirs monorepo_eio
401
397
end;
402
-
setup_and_commit ~fs ~monorepo ~monorepo_eio
398
+
setup_and_commit ~sw ~fs ~monorepo ~monorepo_eio
403
399
end
+2
-1
lib/init.mli
+2
-1
lib/init.mli
···
4
4
CLAUDE.md, .gitignore, and dune-project files. *)
5
5
6
6
val ensure :
7
+
sw:Eio.Switch.t ->
7
8
proc:_ Eio.Process.mgr ->
8
9
fs:Eio.Fs.dir_ty Eio.Path.t ->
9
10
config:Config.t ->
10
11
(unit, Ctx.error) result
11
-
(** [ensure ~proc ~fs ~config] initializes the monorepo if needed. *)
12
+
(** [ensure ~sw ~proc ~fs ~config] initializes the monorepo if needed. *)
12
13
13
14
val write_readme :
14
15
proc:_ Eio.Process.mgr ->
+6
-1
lib/monopam.mli
+6
-1
lib/monopam.mli
···
86
86
any known package. *)
87
87
88
88
val status :
89
+
sw:Eio.Switch.t ->
89
90
fs:Eio.Fs.dir_ty Eio.Path.t ->
90
91
config:Config.t ->
91
92
unit ->
92
93
(Status.t list, Ctx.error) result
93
-
(** [status ~fs ~config ()] computes sync status for all packages. *)
94
+
(** [status ~sw ~fs ~config ()] computes sync status for all packages. *)
94
95
95
96
type handle_pull_result = Diff.handle_pull_result
96
97
type commit_info = Diff.commit_info
···
106
107
(** [pp_diff_result ~show_patch ppf result] pretty-prints a diff result. *)
107
108
108
109
val pull_from_handle :
110
+
sw:Eio.Switch.t ->
109
111
proc:_ Eio.Process.mgr ->
110
112
fs:Eio.Fs.dir_ty Eio.Path.t ->
111
113
config:Config.t ->
···
119
121
from a verse collaborator's handle. *)
120
122
121
123
val diff_show_commit :
124
+
sw:Eio.Switch.t ->
122
125
proc:_ Eio.Process.mgr ->
123
126
fs:Eio.Fs.dir_ty Eio.Path.t ->
124
127
config:Config.t ->
···
131
134
a specific commit in the verse diff. *)
132
135
133
136
val diff :
137
+
sw:Eio.Switch.t ->
134
138
proc:_ Eio.Process.mgr ->
135
139
fs:Eio.Fs.dir_ty Eio.Path.t ->
136
140
config:Config.t ->
···
147
151
(** [is_commit_sha s] returns [true] if [s] looks like a git commit SHA. *)
148
152
149
153
val cherrypick :
154
+
sw:Eio.Switch.t ->
150
155
proc:_ Eio.Process.mgr ->
151
156
fs:Eio.Fs.dir_ty Eio.Path.t ->
152
157
config:Config.t ->
+32
-46
lib/opam_sync.ml
+32
-46
lib/opam_sync.ml
···
33
33
34
34
let read_file_opt path = try Some (Eio.Path.load path) with Eio.Io _ -> None
35
35
36
-
let ensure_repo_file ~fs opam_repo =
36
+
let ensure_repo_file ~sw ~fs opam_repo =
37
37
let repo_content = "opam-version: \"2.0\"\n" in
38
38
let repo_path = Eio.Path.(fs / Fpath.to_string opam_repo / "repo") in
39
39
match read_file_opt repo_path with
40
40
| Some c when c = repo_content -> ()
41
41
| _ -> (
42
42
Eio.Path.save ~create:(`Or_truncate 0o644) repo_path repo_content;
43
-
let repo =
44
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs opam_repo
45
-
in
43
+
let repo = Git.Repository.open_repo ~sw ~fs opam_repo in
46
44
match Git.Repository.add_to_index repo [ "repo" ] with
47
45
| Ok () -> ()
48
46
| Error (`Msg e) ->
···
60
58
| _ -> false)
61
59
with Eio.Io _ -> []
62
60
63
-
let delete_opam_repo_package ~fs ~config name =
61
+
let delete_opam_repo_package ~sw ~fs ~config name =
64
62
let opam_repo = Config.Paths.opam_repo config in
65
63
let pkg_dir = Eio.Path.(fs / Fpath.to_string opam_repo / "packages" / name) in
66
64
try
67
65
Eio.Path.rmtree pkg_dir;
68
-
let repo =
69
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs opam_repo
70
-
in
66
+
let repo = Git.Repository.open_repo ~sw ~fs opam_repo in
71
67
let rel_path = Fmt.str "packages/%s" name in
72
68
(match Git.Repository.remove_from_index repo rel_path with
73
69
| Ok () -> ()
···
79
75
false
80
76
81
77
(** Sync a single package to opam-repo. Returns `Synced or `Unchanged. *)
82
-
let sync_package ~fs ~opam_repo pkg =
78
+
let sync_package ~sw ~fs ~opam_repo pkg =
83
79
let pkg_name = Pkg.name pkg in
84
80
let pkg_dir =
85
81
Fpath.(opam_repo / "packages" / pkg_name / (pkg_name ^ ".dev"))
···
92
88
(try Eio.Path.mkdirs ~perm:0o755 pkg_dir_eio with Eio.Io _ -> ());
93
89
Log.info (fun m -> m "Generating %s.opam in opam-repo" pkg_name);
94
90
Eio.Path.save ~create:(`Or_truncate 0o644) dst_path (Pkg.opam_content pkg);
95
-
let repo =
96
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs opam_repo
97
-
in
91
+
let repo = Git.Repository.open_repo ~sw ~fs opam_repo in
98
92
let rel_path = Fmt.str "packages/%s/%s.dev/opam" pkg_name pkg_name in
99
93
(match Git.Repository.add_to_index repo [ rel_path ] with
100
94
| Ok () -> ()
···
133
127
Sources_registry.empty
134
128
135
129
(** Find and delete orphaned packages in opam-repo. *)
136
-
let delete_orphaned ~fs ~config ~generated_names =
130
+
let delete_orphaned ~sw ~fs ~config ~generated_names =
137
131
let existing = list_opam_repo_packages ~fs ~config in
138
132
let orphaned =
139
133
List.filter (fun name -> not (List.mem name generated_names)) existing
···
141
135
List.iter
142
136
(fun name ->
143
137
Log.info (fun m -> m "Removing orphaned package: %s" name);
144
-
ignore (delete_opam_repo_package ~fs ~config name))
138
+
ignore (delete_opam_repo_package ~sw ~fs ~config name))
145
139
orphaned;
146
140
orphaned
147
141
···
153
147
(fun p -> List.exists (fun n -> Pkg.matches_name n p) names)
154
148
all_pkgs
155
149
156
-
let sync_packages_with_progress ~fs ~opam_repo ~label pkgs =
150
+
let sync_packages_with_progress ~sw ~fs ~opam_repo ~label pkgs =
157
151
let total = List.length pkgs in
158
152
let progress = Tty.Progress.v ~total label in
159
153
let sync_results =
···
161
155
(fun i pkg ->
162
156
Tty.Progress.message progress (Pkg.name pkg);
163
157
Tty.Progress.set progress (i + 1);
164
-
sync_package ~fs ~opam_repo pkg)
158
+
sync_package ~sw ~fs ~opam_repo pkg)
165
159
pkgs
166
160
in
167
161
Tty.Progress.finish progress;
168
162
sync_results
169
163
170
-
let commit_sync_result ~fs ~opam_repo result =
164
+
let commit_sync_result ~sw ~fs ~opam_repo result =
171
165
if result.synced <> [] || result.orphaned <> [] then begin
172
-
let repo =
173
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs opam_repo
174
-
in
166
+
let repo = Git.Repository.open_repo ~sw ~fs opam_repo in
175
167
let msg = commit_message result in
176
168
match Git_cli.global_git_user ~fs () with
177
169
| Some user -> (
···
213
205
not_in_repo = List.rev !not_in_repo;
214
206
}
215
207
216
-
let run ~fs ~config ?(packages = []) () =
208
+
let run ~sw ~fs ~config ?(packages = []) () =
217
209
let monorepo = Config.Paths.monorepo config in
218
210
let sources = load_sources ~fs ~dir:monorepo in
219
211
match Pkg.discover ~fs ~config ~sources () with
···
221
213
| Ok all_pkgs ->
222
214
let pkgs = filter_packages ~packages all_pkgs in
223
215
let opam_repo = Config.Paths.opam_repo config in
224
-
ensure_repo_file ~fs opam_repo;
216
+
ensure_repo_file ~sw ~fs opam_repo;
225
217
let sync_results =
226
-
sync_packages_with_progress ~fs ~opam_repo ~label:"Split" pkgs
218
+
sync_packages_with_progress ~sw ~fs ~opam_repo ~label:"Split" pkgs
227
219
in
228
220
let synced, unchanged =
229
221
List.fold_left
···
235
227
List.map Pkg.name pkgs |> List.sort_uniq String.compare
236
228
in
237
229
let deleted =
238
-
if packages = [] then delete_orphaned ~fs ~config ~generated_names
230
+
if packages = [] then delete_orphaned ~sw ~fs ~config ~generated_names
239
231
else []
240
232
in
241
233
let result =
···
246
238
orphaned = deleted;
247
239
}
248
240
in
249
-
commit_sync_result ~fs ~opam_repo result;
241
+
commit_sync_result ~sw ~fs ~opam_repo result;
250
242
Ok result
251
243
252
244
(** {1 CWD-based Export} *)
···
359
351
with Eio.Io _ -> []
360
352
361
353
(** Delete orphaned package from a standalone opam-repo. *)
362
-
let delete_opam_repo_package_at ~fs opam_repo name =
354
+
let delete_opam_repo_package_at ~sw ~fs opam_repo name =
363
355
let pkg_dir = Eio.Path.(fs / Fpath.to_string opam_repo / "packages" / name) in
364
356
try
365
357
Eio.Path.rmtree pkg_dir;
366
-
let repo =
367
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs opam_repo
368
-
in
358
+
let repo = Git.Repository.open_repo ~sw ~fs opam_repo in
369
359
let rel_path = Fmt.str "packages/%s" name in
370
360
(match Git.Repository.remove_from_index repo rel_path with
371
361
| Ok () -> ()
···
377
367
false
378
368
379
369
(** Sync a single package to a target opam-repo with dry_run support. *)
380
-
let sync_package_to ~fs ~opam_repo ~dry_run pkg =
370
+
let sync_package_to ~sw ~fs ~opam_repo ~dry_run pkg =
381
371
let pkg_name = Pkg.name pkg in
382
372
let pkg_dir =
383
373
Fpath.(opam_repo / "packages" / pkg_name / (pkg_name ^ ".dev"))
···
391
381
(try Eio.Path.mkdirs ~perm:0o755 pkg_dir_eio with Eio.Io _ -> ());
392
382
Log.info (fun m -> m "Generating %s.opam in opam-repo" pkg_name);
393
383
Eio.Path.save ~create:(`Or_truncate 0o644) dst_path (Pkg.opam_content pkg);
394
-
let repo =
395
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs opam_repo
396
-
in
384
+
let repo = Git.Repository.open_repo ~sw ~fs opam_repo in
397
385
let rel_path = Fmt.str "packages/%s/%s.dev/opam" pkg_name pkg_name in
398
386
(match Git.Repository.add_to_index repo [ rel_path ] with
399
387
| Ok () -> ()
···
409
397
([], []) results
410
398
411
399
(** Commit changes in an opam-repo if needed. *)
412
-
let commit_if_needed ~fs ~target ~no_commit ~dry_run result =
400
+
let commit_if_needed ~sw ~fs ~target ~no_commit ~dry_run result =
413
401
if
414
402
(not no_commit) && (not dry_run)
415
403
&& (result.synced <> [] || result.orphaned <> [])
416
404
then begin
417
-
let repo =
418
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs target
419
-
in
405
+
let repo = Git.Repository.open_repo ~sw ~fs target in
420
406
let msg = commit_message result in
421
407
match Git_cli.global_git_user ~fs () with
422
408
| Some user -> (
···
429
415
| None -> Log.warn (fun m -> m "No git user config found, skipping commit")
430
416
end
431
417
432
-
let delete_orphaned_at ~fs ~target ~packages ~generated_names ~dry_run =
418
+
let delete_orphaned_at ~sw ~fs ~target ~packages ~generated_names ~dry_run =
433
419
if packages = [] && not dry_run then begin
434
420
let existing = list_opam_repo_packages_at ~fs target in
435
421
let orphaned =
···
438
424
List.iter
439
425
(fun name ->
440
426
Log.info (fun m -> m "Removing orphaned package: %s" name);
441
-
ignore (delete_opam_repo_package_at ~fs target name))
427
+
ignore (delete_opam_repo_package_at ~sw ~fs target name))
442
428
orphaned;
443
429
orphaned
444
430
end
445
431
else []
446
432
447
-
let export_packages ~fs ~target ~packages ~dry_run ~no_commit pkgs =
448
-
if not dry_run then ensure_repo_file ~fs target;
433
+
let export_packages ~sw ~fs ~target ~packages ~dry_run ~no_commit pkgs =
434
+
if not dry_run then ensure_repo_file ~sw ~fs target;
449
435
let total = List.length pkgs in
450
436
let progress = Tty.Progress.v ~total "Export" in
451
437
let sync_results =
···
453
439
(fun i pkg ->
454
440
Tty.Progress.message progress (Pkg.name pkg);
455
441
Tty.Progress.set progress (i + 1);
456
-
sync_package_to ~fs ~opam_repo:target ~dry_run pkg)
442
+
sync_package_to ~sw ~fs ~opam_repo:target ~dry_run pkg)
457
443
pkgs
458
444
in
459
445
Tty.Progress.finish progress;
···
462
448
List.map Pkg.name pkgs |> List.sort_uniq String.compare
463
449
in
464
450
let deleted =
465
-
delete_orphaned_at ~fs ~target ~packages ~generated_names ~dry_run
451
+
delete_orphaned_at ~sw ~fs ~target ~packages ~generated_names ~dry_run
466
452
in
467
453
let result =
468
454
{
···
472
458
orphaned = deleted;
473
459
}
474
460
in
475
-
commit_if_needed ~fs ~target ~no_commit ~dry_run result;
461
+
commit_if_needed ~sw ~fs ~target ~no_commit ~dry_run result;
476
462
Ok result
477
463
478
-
let run_from_cwd ~fs ~proc:_ ~source ~target ?(packages = [])
464
+
let run_from_cwd ~sw ~fs ~proc:_ ~source ~target ?(packages = [])
479
465
?(no_commit = false) ?(dry_run = false) () =
480
466
match discover_from_cwd ~fs ~source with
481
467
| Error e -> Error e
···
485
471
Log.info (fun m -> m "No packages found to export");
486
472
Ok { synced = []; unchanged = []; missing = []; orphaned = [] }
487
473
end
488
-
else export_packages ~fs ~target ~packages ~dry_run ~no_commit pkgs
474
+
else export_packages ~sw ~fs ~target ~packages ~dry_run ~no_commit pkgs
+2
lib/opam_sync.mli
+2
lib/opam_sync.mli
···
21
21
opam changes or are missing from opam-repo. *)
22
22
23
23
val run :
24
+
sw:Eio.Switch.t ->
24
25
fs:Eio.Fs.dir_ty Eio.Path.t ->
25
26
config:Config.t ->
26
27
?packages:string list ->
···
31
32
*)
32
33
33
34
val run_from_cwd :
35
+
sw:Eio.Switch.t ->
34
36
fs:Eio.Fs.dir_ty Eio.Path.t ->
35
37
proc:_ Eio.Process.mgr ->
36
38
source:Fpath.t ->
+7
-7
lib/progress.mli
+7
-7
lib/progress.mli
···
7
7
{2 Usage}
8
8
9
9
{[
10
-
let progress = Progress.v ~total:10 "Fetching" in
11
-
List.iter
12
-
(fun name ->
13
-
do_work name;
14
-
Progress.tick progress name)
15
-
items;
16
-
Progress.finish progress
10
+
let progress = Progress.v ~total:10 "Fetching" in
11
+
List.iter
12
+
(fun name ->
13
+
do_work name;
14
+
Progress.tick progress name)
15
+
items;
16
+
Progress.finish progress
17
17
]}
18
18
19
19
Or with the functor interface for conditional progress:
+22
-24
lib/pull.ml
+22
-24
lib/pull.ml
···
34
34
| Ok _ -> Ok added
35
35
| Error (`Msg msg) -> Error (Ctx.Git_error (Git_cli.Io_error msg))
36
36
37
-
let subtree ~proc ~fs ~config pkg =
37
+
let subtree ~sw ~proc ~fs ~config pkg =
38
38
let fs = Ctx.fs_typed fs in
39
39
let monorepo = Config.Paths.monorepo config in
40
40
let checkouts_root = Config.Paths.checkouts config in
···
46
46
match Git_cli.fetch_url ~proc ~fs ~repo:monorepo ~url ~branch () with
47
47
| Error e -> Error (Ctx.Git_error e)
48
48
| Ok hash_hex ->
49
-
let git_repo =
50
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs monorepo
51
-
in
49
+
let git_repo = Git.Repository.open_repo ~sw ~fs monorepo in
52
50
let commit = Git.Hash.of_hex hash_hex in
53
51
let user =
54
52
match Git_cli.global_git_user ~fs () with
···
81
79
Log.warn (fun m ->
82
80
m "Failed to update opam repo: %a" Git_cli.pp_error e)
83
81
end
84
-
else begin
85
-
match opam_repo_url with
82
+
else
83
+
begin match opam_repo_url with
86
84
| Some url -> (
87
85
Log.info (fun m ->
88
86
m "Cloning opam repo from %s to %a" url Fpath.pp opam_repo);
···
96
94
Log.info (fun m ->
97
95
m "Opam repo at %a does not exist and no URL provided" Fpath.pp
98
96
opam_repo)
99
-
end
97
+
end
100
98
101
-
let clone_repos ~proc ~fs ~config repos =
99
+
let clone_repos ~sw ~proc ~fs ~config repos =
102
100
let total = List.length repos in
103
101
let progress = Tty.Progress.v ~total "Fetch" in
104
102
let rec loop acc = function
···
111
109
(Fmt.str "Fetch: %s (%d/%d)" repo_name (List.length acc + 1) total);
112
110
Log.info (fun m -> m "Fetching repo %s" repo_name);
113
111
let existed = Ctx.checkout_exists ~fs ~config pkg in
114
-
let behind_before = if existed then Ctx.behind ~fs ~config pkg else 0 in
112
+
let behind_before =
113
+
if existed then Ctx.behind ~sw ~fs ~config pkg else 0
114
+
in
115
115
match Ctx.ensure_checkout ~proc ~fs ~config pkg with
116
116
| Error e ->
117
117
Tty.Progress.clear progress;
···
130
130
in
131
131
loop [] repos
132
132
133
-
let process_subtrees ~proc ~fs ~config repos checkout_results =
133
+
let process_subtrees ~sw ~proc ~fs ~config repos checkout_results =
134
134
let total = List.length repos in
135
135
let progress = Tty.Progress.v ~total "Subtree" in
136
136
let rec loop results_acc repos_left checkout_results_left =
···
145
145
(List.length results_acc + 1)
146
146
total);
147
147
Log.info (fun m -> m "Subtree %s" name);
148
-
match subtree ~proc ~fs ~config pkg with
148
+
match subtree ~sw ~proc ~fs ~config pkg with
149
149
| Ok subtree_added ->
150
150
Tty.Progress.tick progress;
151
151
let result = { cr with subtree_added } in
···
213
213
end
214
214
215
215
(** Fetch a checkout into the monorepo and merge as a subtree. *)
216
-
let merge_inner_subtree ~proc ~fs_t ~monorepo ~prefix ~checkout_dir ~branch =
216
+
let merge_inner_subtree ~sw ~proc ~fs_t ~monorepo ~prefix ~checkout_dir ~branch
217
+
=
217
218
let url = Fpath.to_string checkout_dir in
218
219
let subtree_exists = Ctx.is_directory ~fs:fs_t Fpath.(monorepo / prefix) in
219
220
match Git_cli.fetch_url ~proc ~fs:fs_t ~repo:monorepo ~url ~branch () with
···
221
222
Log.warn (fun m ->
222
223
m "Failed to fetch %s into monorepo: %a" prefix Git_cli.pp_error e)
223
224
| Ok hash_hex -> (
224
-
let git_repo =
225
-
Eio.Switch.run @@ fun sw ->
226
-
Git.Repository.open_repo ~sw ~fs:fs_t monorepo
227
-
in
225
+
let git_repo = Git.Repository.open_repo ~sw ~fs:fs_t monorepo in
228
226
let commit = Git.Hash.of_hex hash_hex in
229
227
let user =
230
228
match Git_cli.global_git_user ~fs:fs_t () with
···
247
245
(** Pull inner subtrees for mono=true entries. For each entry in the inner
248
246
sources.toml, fetches the checkout and merges at the nested prefix. Inner
249
247
subtrees are processed first (depth-first). *)
250
-
let mono_entries ~proc ~fs ~config =
248
+
let mono_entries ~sw ~proc ~fs ~config =
251
249
let fs_t = Ctx.fs_typed fs in
252
250
let monorepo = Config.Paths.monorepo config in
253
251
let checkouts_root = Config.Paths.checkouts config in
···
290
288
~name:inner_name ~label:nested_prefix ~branch
291
289
in
292
290
if fetched then
293
-
merge_inner_subtree ~proc ~fs_t ~monorepo
291
+
merge_inner_subtree ~sw ~proc ~fs_t ~monorepo
294
292
~prefix:nested_prefix ~checkout_dir ~branch)
295
293
inner_entries)
296
294
mono
297
295
end
298
296
299
-
let run ~proc ~fs ~config ?(packages = []) ?opam_repo_url () =
297
+
let run ~sw ~proc ~fs ~config ?(packages = []) ?opam_repo_url () =
300
298
let ( let* ) = Result.bind in
301
299
let fs_t = Ctx.fs_typed fs in
302
300
let opam_repo = Config.Paths.opam_repo config in
303
301
ensure_opam_repo ~proc ~fs:fs_t ~opam_repo ~opam_repo_url;
304
302
Ctx.ensure_checkouts_dir ~fs:fs_t ~config;
305
-
let* () = Init.ensure ~proc ~fs:fs_t ~config in
303
+
let* () = Init.ensure ~sw ~proc ~fs:fs_t ~config in
306
304
let* all_pkgs = Ctx.discover_packages ~fs:(fs_t :> _ Eio.Path.t) ~config () in
307
305
let pkgs =
308
306
match packages with
···
316
314
Error (Ctx.Package_not_found (List.hd packages))
317
315
else begin
318
316
Log.info (fun m -> m "Checking status of %d packages" (List.length pkgs));
319
-
let statuses = Status.compute_all ~fs:fs_t ~config pkgs in
317
+
let statuses = Status.compute_all ~sw ~fs:fs_t ~config pkgs in
320
318
let dirty =
321
319
List.filter Status.has_local_changes statuses
322
320
|> List.map (fun s -> s.Status.package)
···
324
322
if dirty <> [] then Error (Ctx.Dirty_state dirty)
325
323
else begin
326
324
(* Pull mono inner subtrees first (depth-first) *)
327
-
mono_entries ~proc ~fs ~config;
325
+
mono_entries ~sw ~proc ~fs ~config;
328
326
let repos = Ctx.unique_repos pkgs in
329
327
Log.info (fun m ->
330
328
m "Cloning/fetching %d unique repositories" (List.length repos));
331
-
let* checkout_results = clone_repos ~proc ~fs:fs_t ~config repos in
329
+
let* checkout_results = clone_repos ~sw ~proc ~fs:fs_t ~config repos in
332
330
Log.info (fun m -> m "Processing %d unique subtrees" (List.length repos));
333
331
let* results =
334
-
process_subtrees ~proc ~fs ~config repos checkout_results
332
+
process_subtrees ~sw ~proc ~fs ~config repos checkout_results
335
333
in
336
334
log_pull_results results;
337
335
Init.write_readme ~proc ~fs:fs_t ~config all_pkgs;
+4
-2
lib/pull.mli
+4
-2
lib/pull.mli
···
9
9
(** Result of a pull operation for a single repository. *)
10
10
11
11
val subtree :
12
+
sw:Eio.Switch.t ->
12
13
proc:_ Eio.Process.mgr ->
13
14
fs:Eio.Fs.dir_ty Eio.Path.t ->
14
15
config:Config.t ->
15
16
Package.t ->
16
17
(bool, Ctx.error) Stdlib.result
17
-
(** [subtree ~proc ~fs ~config pkg] merges or adds the subtree for [pkg].
18
+
(** [subtree ~sw ~proc ~fs ~config pkg] merges or adds the subtree for [pkg].
18
19
Returns [true] if the subtree was newly added. *)
19
20
20
21
val run :
22
+
sw:Eio.Switch.t ->
21
23
proc:_ Eio.Process.mgr ->
22
24
fs:Eio.Fs.dir_ty Eio.Path.t ->
23
25
config:Config.t ->
···
25
27
?opam_repo_url:string ->
26
28
unit ->
27
29
(unit, Ctx.error) Stdlib.result
28
-
(** [run ~proc ~fs ~config ()] fetches checkouts and merges subtrees. *)
30
+
(** [run ~sw ~proc ~fs ~config ()] fetches checkouts and merges subtrees. *)
+35
-49
lib/push.ml
+35
-49
lib/push.ml
···
9
9
10
10
(** {1 Single Package Push} *)
11
11
12
-
let checkout_tree_hash ~fs checkout_dir =
13
-
let checkout_repo =
14
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs checkout_dir
15
-
in
12
+
let checkout_tree_hash ~sw ~fs checkout_dir =
13
+
let checkout_repo = Git.Repository.open_repo ~sw ~fs checkout_dir in
16
14
match Git.Repository.head checkout_repo with
17
15
| None -> None
18
16
| Some h -> (
···
110
108
| Skipped (** Nothing to push (up-to-date or not in monorepo) *)
111
109
| Clone_failed of string (** Remote repo doesn't exist or is unreachable *)
112
110
113
-
let one ~proc ~fs ~config ~sources ~clean ~force pkg =
111
+
let one ~sw ~proc ~fs ~config ~sources ~clean ~force pkg =
114
112
let ( let* ) r f =
115
113
Result.bind (Result.map_error (fun e -> Ctx.Git_error e) r) f
116
114
in
···
148
146
else
149
147
let* () = Ok () in
150
148
let checkout_url = Fpath.to_string checkout_dir in
151
-
let git_repo =
152
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs monorepo
153
-
in
149
+
let git_repo = Git.Repository.open_repo ~sw ~fs monorepo in
154
150
let mono_tree =
155
151
Git.Repository.tree_hash_at_path git_repo ~rev:"HEAD" ~path:prefix
156
152
in
157
-
let checkout_tree = checkout_tree_hash ~fs checkout_dir in
153
+
let checkout_tree = checkout_tree_hash ~sw ~fs checkout_dir in
158
154
if mono_tree = checkout_tree && mono_tree <> None then begin
159
155
Log.debug (fun m -> m "Skipping %s (trees match)" prefix);
160
156
Ok Skipped
···
187
183
| None -> true
188
184
| Some remote_head -> not (Git.Hash.equal local_head remote_head))
189
185
190
-
let commit_pending ~fs path name =
191
-
let repo =
192
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs path
193
-
in
186
+
let commit_pending ~sw ~fs path name =
187
+
let repo = Git.Repository.open_repo ~sw ~fs path in
194
188
match Git.Repository.add_all repo with
195
189
| Error (`Msg e) ->
196
190
Log.warn (fun m -> m "Failed to stage changes in %s: %s" name e)
···
211
205
| Error (`Msg e) ->
212
206
Log.warn (fun m -> m "Failed to commit in %s: %s" name e)))
213
207
214
-
let workspace_repos ~proc ~fs ~config ~force ~push_mono =
208
+
let workspace_repos ~sw ~proc ~fs ~config ~force ~push_mono =
215
209
let knot = Config.knot config in
216
210
let errors = ref [] in
217
211
let push_repo ~commit name path =
218
212
if Git.Repository.is_repo ~fs path then begin
219
-
let repo =
220
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs path
221
-
in
213
+
let repo = Git.Repository.open_repo ~sw ~fs path in
222
214
match Git.Repository.remote_url repo "origin" with
223
215
| None -> Log.debug (fun m -> m "%s has no origin remote, skipping" name)
224
216
| Some fetch_url -> (
···
230
222
| Ok () -> ()
231
223
| Error (`Msg msg) ->
232
224
Log.warn (fun m -> m "Failed to set push URL for %s: %s" name msg));
233
-
if commit then commit_pending ~fs path name;
225
+
if commit then commit_pending ~sw ~fs path name;
234
226
let branch =
235
227
Git.Repository.current_branch repo |> Option.value ~default:"main"
236
228
in
···
260
252
261
253
type missing_repo = { pkg : Package.t; url : string }
262
254
263
-
let export_repos ~proc ~fs ~config ~sources ~clean ~force ~progress repos =
255
+
let export_repos ~sw ~proc ~fs ~config ~sources ~clean ~force ~progress repos =
264
256
let update_progress name =
265
257
Tty.Progress.update progress ~phase:"Export" ~msg:name
266
258
in
···
270
262
let name = Package.subtree_prefix pkg in
271
263
update_progress name;
272
264
Log.debug (fun m -> m "Subtree push %s" name);
273
-
match one ~proc ~fs ~config ~sources ~clean ~force pkg with
265
+
match one ~sw ~proc ~fs ~config ~sources ~clean ~force pkg with
274
266
| Ok Pushed -> loop (pkg :: pushed_repos) missing rest
275
267
| Ok Skipped -> loop pushed_repos missing rest
276
268
| Ok (Clone_failed url) ->
···
281
273
in
282
274
loop [] [] repos
283
275
284
-
let to_upstream ~proc ~fs ~config ~sources ~force ~progress pushed_repos =
276
+
let to_upstream ~sw ~proc ~fs ~config ~sources ~force ~progress pushed_repos =
285
277
Log.info (fun m ->
286
278
m "Pushing %d repos to upstream (parallel)" (List.length pushed_repos));
287
279
let checkouts_root = Config.Paths.checkouts config in
···
295
287
let fetch_url = resolve_fetch_url ~sources pkg in
296
288
let push_url = Ctx.url_to_push_url ~knot fetch_url in
297
289
Log.info (fun m -> m "Pushing %s to %s" name push_url);
298
-
let repo =
299
-
Eio.Switch.run @@ fun sw ->
300
-
Git.Repository.open_repo ~sw ~fs checkout_dir
301
-
in
290
+
let repo = Git.Repository.open_repo ~sw ~fs checkout_dir in
302
291
(match
303
292
Git.Repository.ensure_remote repo ~name:"origin" ~url:fetch_url
304
293
with
···
375
364
else true
376
365
377
366
(** Configure a checkout and push a subtree split to it. *)
378
-
let inner_subtree ~proc ~fs_t ~monorepo ~git_repo ~prefix ~checkout_dir ~name
379
-
~clean ~force ~branch =
367
+
let inner_subtree ~sw ~proc ~fs_t ~monorepo ~git_repo ~prefix ~checkout_dir
368
+
~name ~clean ~force ~branch =
380
369
(match
381
370
Git_cli.ensure_receive_config ~proc ~fs:(fs_t :> _ Eio.Path.t) checkout_dir
382
371
with
···
384
373
| Error e ->
385
374
Log.warn (fun m -> m "Failed to configure %s: %a" name Git_cli.pp_error e));
386
375
let checkout_url = Fpath.to_string checkout_dir in
387
-
let checkout_tree = checkout_tree_hash ~fs:fs_t checkout_dir in
376
+
let checkout_tree = checkout_tree_hash ~sw ~fs:fs_t checkout_dir in
388
377
match
389
378
split_and_push ~proc ~fs:fs_t ~monorepo ~git_repo ~prefix ~checkout_url
390
379
~checkout_tree ~clean ~force ~branch
···
397
386
398
387
(** Process one mono entry: load its inner sources.toml and push each inner
399
388
subtree. *)
400
-
let mono_inner ~proc ~fs_t ~monorepo ~checkouts_root ~git_repo ~clean ~force
389
+
let mono_inner ~sw ~proc ~fs_t ~monorepo ~checkouts_root ~git_repo ~clean ~force
401
390
mono_name =
402
391
let inner_sources_path = Fpath.(monorepo / mono_name / "sources.toml") in
403
392
match Sources_registry.load ~fs:(fs_t :> _ Eio.Path.t) inner_sources_path with
···
422
411
~name:inner_name ~label:nested_prefix ~branch
423
412
in
424
413
if cloned then
425
-
inner_subtree ~proc ~fs_t ~monorepo ~git_repo
414
+
inner_subtree ~sw ~proc ~fs_t ~monorepo ~git_repo
426
415
~prefix:nested_prefix ~checkout_dir ~name:inner_name ~clean
427
416
~force ~branch
428
417
end)
···
431
420
(** Push inner subtrees of mono=true entries. For each entry in the inner
432
421
sources.toml, splits at the nested prefix and pushes to a shared checkout.
433
422
*)
434
-
let mono_entries ~proc ~fs ~config ~sources ~clean ~force =
423
+
let mono_entries ~sw ~proc ~fs ~config ~sources ~clean ~force =
435
424
let fs_t = Ctx.fs_typed fs in
436
425
let monorepo = Config.Paths.monorepo config in
437
426
let checkouts_root = Config.Paths.checkouts config in
···
443
432
Log.info (fun m ->
444
433
m "Processing %d mono entries for inner subtree push"
445
434
(List.length mono));
446
-
let git_repo =
447
-
Eio.Switch.run @@ fun sw ->
448
-
Git.Repository.open_repo ~sw ~fs:fs_t monorepo
449
-
in
435
+
let git_repo = Git.Repository.open_repo ~sw ~fs:fs_t monorepo in
450
436
List.iter
451
437
(fun (mono_name, _mono_entry) ->
452
-
mono_inner ~proc ~fs_t ~monorepo ~checkouts_root ~git_repo ~clean
453
-
~force mono_name)
438
+
mono_inner ~sw ~proc ~fs_t ~monorepo ~checkouts_root ~git_repo
439
+
~clean ~force mono_name)
454
440
mono
455
441
end
456
442
···
491
477
missing
492
478
end
493
479
494
-
let export_and_push ~proc ~fs ~fs_t ~config ~sources ~upstream ~push_mono ~clean
495
-
~force ~all_pkgs repos =
480
+
let export_and_push ~sw ~proc ~fs ~fs_t ~config ~sources ~upstream ~push_mono
481
+
~clean ~force ~all_pkgs repos =
496
482
let n_repos = List.length repos in
497
483
let total = if upstream then n_repos * 2 else n_repos in
498
484
let progress = Tty.Progress.v ~total "Push" in
499
485
match
500
-
export_repos ~proc ~fs ~config ~sources ~clean ~force ~progress repos
486
+
export_repos ~sw ~proc ~fs ~config ~sources ~clean ~force ~progress repos
501
487
with
502
488
| Error e -> Error e
503
489
| Ok (pushed_repos, missing) -> (
504
490
let push_results =
505
491
if upstream && pushed_repos <> [] then
506
-
to_upstream ~proc ~fs:fs_t ~config ~sources ~force ~progress
492
+
to_upstream ~sw ~proc ~fs:fs_t ~config ~sources ~force ~progress
507
493
pushed_repos
508
494
else List.map (fun p -> Ok (Package.repo_name p)) pushed_repos
509
495
in
···
514
500
| Ok () ->
515
501
let ws_errors =
516
502
if upstream then
517
-
workspace_repos ~proc ~fs:fs_t ~config ~force ~push_mono
503
+
workspace_repos ~sw ~proc ~fs:fs_t ~config ~force ~push_mono
518
504
else []
519
505
in
520
506
if ws_errors <> [] then
···
528
514
| Ok s -> Some s
529
515
| Error _ -> None
530
516
531
-
let run ~proc ~fs ~config ?(packages = []) ?(upstream = false) ?(clean = false)
532
-
?(force = false) () =
517
+
let run ~sw ~proc ~fs ~config ?(packages = []) ?(upstream = false)
518
+
?(clean = false) ?(force = false) () =
533
519
let fs_t = Ctx.fs_typed fs in
534
520
Ctx.ensure_checkouts_dir ~fs:fs_t ~config;
535
521
match Ctx.discover_packages ~fs:(fs_t :> _ Eio.Path.t) ~config () with
···
548
534
else begin
549
535
Log.info (fun m ->
550
536
m "Checking status of %d packages" (List.length pkgs));
551
-
let statuses = Status.compute_all ~fs:fs_t ~config pkgs in
537
+
let statuses = Status.compute_all ~sw ~fs:fs_t ~config pkgs in
552
538
let dirty =
553
539
List.filter Status.has_local_changes statuses
554
540
|> List.map (fun s -> s.Status.package)
···
556
542
if dirty <> [] then Error (Ctx.Dirty_state dirty)
557
543
else begin
558
544
(* Sync opam files to opam-repo before pushing *)
559
-
(match Opam_sync.run ~fs:fs_t ~config ~packages () with
545
+
(match Opam_sync.run ~sw ~fs:fs_t ~config ~packages () with
560
546
| Ok r ->
561
547
if r.Opam_sync.synced <> [] then
562
548
Log.app (fun m ->
···
565
551
Log.warn (fun m -> m "Opam sync failed: %s" msg));
566
552
let sources = load_sources ~fs:fs_t ~config in
567
553
(* Push mono inner subtrees first (depth-first) *)
568
-
mono_entries ~proc ~fs ~config ~sources ~clean ~force;
554
+
mono_entries ~sw ~proc ~fs ~config ~sources ~clean ~force;
569
555
let to_push = repos_to_push statuses pkgs in
570
556
Log.info (fun m -> m "Pushing %d unique repos" (List.length to_push));
571
557
let push_mono = packages = [] in
···
573
559
Log.app (fun m -> m "Nothing to push (all repos in sync)");
574
560
let ws_errors =
575
561
if upstream then
576
-
workspace_repos ~proc ~fs:fs_t ~config ~force ~push_mono
562
+
workspace_repos ~sw ~proc ~fs:fs_t ~config ~force ~push_mono
577
563
else []
578
564
in
579
565
if ws_errors <> [] then
···
582
568
else Ok ()
583
569
end
584
570
else
585
-
export_and_push ~proc ~fs ~fs_t ~config ~sources ~upstream
571
+
export_and_push ~sw ~proc ~fs ~fs_t ~config ~sources ~upstream
586
572
~push_mono ~clean ~force ~all_pkgs:pkgs to_push
587
573
end
588
574
end
+1
lib/push.mli
+1
lib/push.mli
+11
-11
lib/remote_cache.mli
+11
-11
lib/remote_cache.mli
···
20
20
{2 Example with mock time}
21
21
22
22
{[
23
-
let time = ref 0.0 in
24
-
let now () = !time in
25
-
let cache = Remote_cache.v ~ttl:60.0 ~now () in
23
+
let time = ref 0.0 in
24
+
let now () = !time in
25
+
let cache = Remote_cache.v ~ttl:60.0 ~now () in
26
26
27
-
(* Set a value *)
28
-
let url = Uri.of_string "https://github.com/ocaml/ocaml.git" in
29
-
Remote_cache.set cache ~url ~branch:"trunk" ~hash:"abc123";
27
+
(* Set a value *)
28
+
let url = Uri.of_string "https://github.com/ocaml/ocaml.git" in
29
+
Remote_cache.set cache ~url ~branch:"trunk" ~hash:"abc123";
30
30
31
-
(* Get it back immediately *)
32
-
assert (Remote_cache.find cache ~url ~branch:"trunk" = Some "abc123");
31
+
(* Get it back immediately *)
32
+
assert (Remote_cache.find cache ~url ~branch:"trunk" = Some "abc123");
33
33
34
-
(* Advance time past TTL *)
35
-
time := 61.0;
36
-
assert (Remote_cache.find cache ~url ~branch:"trunk" = None)
34
+
(* Advance time past TTL *)
35
+
time := 61.0;
36
+
assert (Remote_cache.find cache ~url ~branch:"trunk" = None)
37
37
]} *)
38
38
39
39
type t
+1
-3
lib/sources_registry.mli
+1
-3
lib/sources_registry.mli
···
10
10
11
11
The registry also supports an [origin] field (formerly [default_url_base])
12
12
that is used to derive URLs for subtrees without explicit entries:
13
-
{v
14
-
origin = "git+https://tangled.org/anil.recoil.org"
15
-
v}
13
+
{v origin = "git+https://tangled.org/anil.recoil.org" v}
16
14
For a subtree named "ocaml-foo", this would produce:
17
15
[git+https://tangled.org/anil.recoil.org/ocaml-foo] *)
18
16
+11
-19
lib/status.ml
+11
-19
lib/status.ml
···
42
42
{ ahead = ab.ahead; behind = ab.behind }
43
43
44
44
(** Pre-compute all subtree hashes from mono repo's HEAD *)
45
-
let subtree_hashes ~fs ~monorepo =
46
-
let mono_repo =
47
-
Eio.Switch.run @@ fun sw -> Git.Repository.open_repo ~sw ~fs monorepo
48
-
in
45
+
let subtree_hashes ~sw ~fs ~monorepo =
46
+
let mono_repo = Git.Repository.open_repo ~sw ~fs monorepo in
49
47
match Git.Repository.read_ref mono_repo "HEAD" with
50
48
| None -> Hashtbl.create 0
51
49
| Some commit_hash -> (
···
67
65
68
66
(** Internal: compute status for a single package with pre-computed subtree
69
67
hashes *)
70
-
let compute_one ~fs ~checkouts_root ~monorepo ~subtree_hashes pkg =
68
+
let compute_one ~sw ~fs ~checkouts_root ~monorepo ~subtree_hashes pkg =
71
69
let checkout_dir = Package.checkout_dir ~checkouts_root pkg in
72
70
let prefix = Package.subtree_prefix pkg in
73
71
let checkout =
74
72
if not (dir_exists fs checkout_dir) then Missing
75
73
else if not (Git.Repository.is_repo ~fs checkout_dir) then Not_a_repo
76
74
else
77
-
let repo =
78
-
Eio.Switch.run @@ fun sw ->
79
-
Git.Repository.open_repo ~sw ~fs checkout_dir
80
-
in
75
+
let repo = Git.Repository.open_repo ~sw ~fs checkout_dir in
81
76
if Git.Repository.is_dirty repo then Dirty
82
77
else
83
78
let branch =
···
96
91
| (Missing | Not_a_repo | Dirty), _ -> Unknown
97
92
| _, Not_added -> Unknown
98
93
| (Clean _ | No_upstream), Present -> (
99
-
let checkout_repo =
100
-
Eio.Switch.run @@ fun sw ->
101
-
Git.Repository.open_repo ~sw ~fs checkout_dir
102
-
in
94
+
let checkout_repo = Git.Repository.open_repo ~sw ~fs checkout_dir in
103
95
let subtree_tree = Hashtbl.find_opt subtree_hashes prefix in
104
96
let checkout_tree =
105
97
Git.Repository.tree_hash_at_path checkout_repo ~rev:"HEAD" ~path:""
···
111
103
in
112
104
{ package = pkg; checkout; subtree; subtree_sync }
113
105
114
-
let compute ~fs ~config pkg =
106
+
let compute ~sw ~fs ~config pkg =
115
107
let fs_t = fs_typed fs in
116
108
let checkouts_root = Config.Paths.checkouts config in
117
109
let monorepo = Config.Paths.monorepo config in
118
-
let subtree_hashes = subtree_hashes ~fs:fs_t ~monorepo in
119
-
compute_one ~fs:fs_t ~checkouts_root ~monorepo ~subtree_hashes pkg
110
+
let subtree_hashes = subtree_hashes ~sw ~fs:fs_t ~monorepo in
111
+
compute_one ~sw ~fs:fs_t ~checkouts_root ~monorepo ~subtree_hashes pkg
120
112
121
-
let compute_all ~fs ~config packages =
113
+
let compute_all ~sw ~fs ~config packages =
122
114
let fs_t = fs_typed fs in
123
115
let checkouts_root = Config.Paths.checkouts config in
124
116
let monorepo = Config.Paths.monorepo config in
125
117
(* Pre-compute all subtree hashes once *)
126
-
let subtree_hashes = subtree_hashes ~fs:fs_t ~monorepo in
118
+
let subtree_hashes = subtree_hashes ~sw ~fs:fs_t ~monorepo in
127
119
Eio.Fiber.List.map ~max_fibers:8
128
-
(compute_one ~fs:fs_t ~checkouts_root ~monorepo ~subtree_hashes)
120
+
(compute_one ~sw ~fs:fs_t ~checkouts_root ~monorepo ~subtree_hashes)
129
121
packages
130
122
131
123
let is_checkout_clean t =
+13
-4
lib/status.mli
+13
-4
lib/status.mli
···
45
45
46
46
(** {1 Status Computation} *)
47
47
48
-
val compute : fs:Eio.Fs.dir_ty Eio.Path.t -> config:Config.t -> Package.t -> t
49
-
(** [compute ~fs ~config pkg] computes the status of a single package. *)
48
+
val compute :
49
+
sw:Eio.Switch.t ->
50
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
51
+
config:Config.t ->
52
+
Package.t ->
53
+
t
54
+
(** [compute ~sw ~fs ~config pkg] computes the status of a single package. *)
50
55
51
56
val compute_all :
52
-
fs:Eio.Fs.dir_ty Eio.Path.t -> config:Config.t -> Package.t list -> t list
53
-
(** [compute_all ~fs ~config packages] computes status for all packages. *)
57
+
sw:Eio.Switch.t ->
58
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
59
+
config:Config.t ->
60
+
Package.t list ->
61
+
t list
62
+
(** [compute_all ~sw ~fs ~config packages] computes status for all packages. *)
54
63
55
64
(** {1 Predicates} *)
56
65
+7
-7
lib/sync_progress.mli
+7
-7
lib/sync_progress.mli
···
7
7
{2 Usage}
8
8
9
9
{[
10
-
let progress = Sync_progress.v ~total:10 "Fetching" in
11
-
List.iter
12
-
(fun name ->
13
-
do_work name;
14
-
Sync_progress.tick progress name)
15
-
items;
16
-
Sync_progress.finish progress
10
+
let progress = Sync_progress.v ~total:10 "Fetching" in
11
+
List.iter
12
+
(fun name ->
13
+
do_work name;
14
+
Sync_progress.tick progress name)
15
+
items;
16
+
Sync_progress.finish progress
17
17
]}
18
18
19
19
Or with the functor interface for conditional progress:
+20
-22
lib/verse.ml
+20
-22
lib/verse.ml
···
176
176
Logs.info (fun m -> m "Opam repo cloned");
177
177
Ok ())
178
178
179
-
let init ~proc ~fs ~root ~handle () =
179
+
let init ~sw ~proc ~fs ~root ~handle () =
180
180
let config_file = Verse_config.file () in
181
181
Logs.info (fun m -> m "Config file: %a" Fpath.pp config_file);
182
182
if is_file ~fs config_file then begin
···
188
188
Logs.info (fun m -> m "Workspace root: %a" Fpath.pp root);
189
189
let config = Verse_config.v ~root ~handle () in
190
190
Logs.info (fun m -> m "Cloning registry...");
191
-
match Verse_registry.clone_or_pull ~proc ~fs ~config () with
191
+
match Verse_registry.clone_or_pull ~sw ~proc ~fs ~config () with
192
192
| Error msg ->
193
193
Logs.err (fun m -> m "Registry clone failed: %s" msg);
194
194
Error (Registry_error msg)
···
223
223
Logs.info (fun m -> m "Workspace initialized successfully");
224
224
Ok ())))
225
225
226
-
let status ~proc ~fs ~config () =
226
+
let status ~sw ~proc ~fs ~config () =
227
227
(* Load registry *)
228
-
match Verse_registry.clone_or_pull ~proc ~fs ~config () with
228
+
match Verse_registry.clone_or_pull ~sw ~proc ~fs ~config () with
229
229
| Error msg -> Error (Registry_error msg)
230
230
| Ok registry ->
231
231
(* Get tracked handles *)
···
258
258
let cloned = Git.Repository.is_repo ~fs local_path in
259
259
let clean, ahead_behind =
260
260
if cloned then
261
-
let repo =
262
-
Eio.Switch.run @@ fun sw ->
263
-
Git.Repository.open_repo ~sw ~fs local_path
264
-
in
261
+
let repo = Git.Repository.open_repo ~sw ~fs local_path in
265
262
let clean = Some (not (Git.Repository.is_dirty repo)) in
266
263
let ahead_behind = Git.Repository.ahead_behind repo () in
267
264
(clean, ahead_behind)
···
280
277
in
281
278
Ok { config; registry; tracked_members }
282
279
283
-
let members ~proc ~fs ~config () =
284
-
match Verse_registry.clone_or_pull ~proc ~fs ~config () with
280
+
let members ~sw ~proc ~fs ~config () =
281
+
match Verse_registry.clone_or_pull ~sw ~proc ~fs ~config () with
285
282
| Error msg -> Error (Registry_error msg)
286
283
| Ok registry -> Ok registry.members
287
284
···
289
286
if reset. Uses fetch+reset instead of pull since verse repos should not have
290
287
local changes. *)
291
288
let clone_or_reset_repo ~proc ~fs ~url ~branch path =
292
-
if Git.Repository.is_repo ~fs path then begin
293
-
match Git_cli.fetch_and_reset ~proc ~fs ~branch path with
289
+
if Git.Repository.is_repo ~fs path then
290
+
begin match Git_cli.fetch_and_reset ~proc ~fs ~branch path with
294
291
| Error e -> Error e
295
292
| Ok () -> Ok false
296
-
end
297
-
else begin
298
-
match Git_cli.clone ~proc ~fs ~url ~branch path with
293
+
end
294
+
else
295
+
begin match Git_cli.clone ~proc ~fs ~url ~branch path with
299
296
| Error e -> Error e
300
297
| Ok () -> Ok true
301
-
end
298
+
end
302
299
303
300
let sync_repo_result ~label h result =
304
301
match result with
···
339
336
| Some e, None | None, Some e -> Some e
340
337
| Some e1, Some e2 -> Some (e1 ^ "; " ^ e2)
341
338
342
-
let pull ~proc ~fs ~config ?handle () =
343
-
match Verse_registry.clone_or_pull ~proc ~fs ~config () with
339
+
let pull ~sw ~proc ~fs ~config ?handle () =
340
+
match Verse_registry.clone_or_pull ~sw ~proc ~fs ~config () with
344
341
| Error msg -> Error (Registry_error msg)
345
342
| Ok registry ->
346
343
let members =
···
366
363
else Error (Git_error (Git_cli.Io_error (String.concat "; " errors)))
367
364
end
368
365
369
-
let sync ~proc ~fs ~config () =
366
+
let sync ~sw ~proc ~fs ~config () =
370
367
(* pull already updates registry and syncs all members *)
371
-
pull ~proc ~fs ~config ()
368
+
pull ~sw ~proc ~fs ~config ()
372
369
373
370
(** Scan a monorepo for subtree directories. Returns a list of directory names
374
371
that look like subtrees (have commits). *)
···
538
535
execute_fork ~fs ~member_opam_repo ~user_opam_repo ~fork_url ~handle
539
536
~upstream_url ~subtree_name related_pkgs
540
537
541
-
let fork ~proc ~fs ~config ~handle ~package ~fork_url ?(dry_run = false) () =
542
-
match Verse_registry.clone_or_pull ~proc ~fs ~config () with
538
+
let fork ~sw ~proc ~fs ~config ~handle ~package ~fork_url ?(dry_run = false) ()
539
+
=
540
+
match Verse_registry.clone_or_pull ~sw ~proc ~fs ~config () with
543
541
| Error msg -> Error (Registry_error msg)
544
542
| Ok registry -> (
545
543
match Verse_registry.member registry ~handle with
+6
lib/verse.mli
+6
lib/verse.mli
···
57
57
(** {1 Operations} *)
58
58
59
59
val init :
60
+
sw:Eio.Switch.t ->
60
61
proc:_ Eio.Process.mgr ->
61
62
fs:Eio.Fs.dir_ty Eio.Path.t ->
62
63
root:Fpath.t ->
···
83
84
@param handle User's handle. *)
84
85
85
86
val status :
87
+
sw:Eio.Switch.t ->
86
88
proc:_ Eio.Process.mgr ->
87
89
fs:Eio.Fs.dir_ty Eio.Path.t ->
88
90
config:Verse_config.t ->
···
93
95
Shows which members are tracked and the state of their local clones. *)
94
96
95
97
val members :
98
+
sw:Eio.Switch.t ->
96
99
proc:_ Eio.Process.mgr ->
97
100
fs:Eio.Fs.dir_ty Eio.Path.t ->
98
101
config:Verse_config.t ->
···
103
106
Pulls the latest registry before returning the member list. *)
104
107
105
108
val pull :
109
+
sw:Eio.Switch.t ->
106
110
proc:_ Eio.Process.mgr ->
107
111
fs:Eio.Fs.dir_ty Eio.Path.t ->
108
112
config:Verse_config.t ->
···
119
123
@param handle Optional specific member to sync. *)
120
124
121
125
val sync :
126
+
sw:Eio.Switch.t ->
122
127
proc:_ Eio.Process.mgr ->
123
128
fs:Eio.Fs.dir_ty Eio.Path.t ->
124
129
config:Verse_config.t ->
···
162
167
(** [pp_fork_result] formats a fork result. *)
163
168
164
169
val fork :
170
+
sw:Eio.Switch.t ->
165
171
proc:_ Eio.Process.mgr ->
166
172
fs:Eio.Fs.dir_ty Eio.Path.t ->
167
173
config:Verse_config.t ->
+1
-2
lib/verse_registry.ml
+1
-2
lib/verse_registry.ml
···
127
127
Ok ()
128
128
with Eio.Io _ as e -> Error (Printexc.to_string e)
129
129
130
-
let clone_or_pull ~proc ~fs ~config:_ () =
130
+
let clone_or_pull ~sw ~proc ~fs ~config:_ () =
131
131
let registry_path = Verse_config.registry_path () in
132
132
let registry_toml = Fpath.(registry_path / "opamverse.toml") in
133
133
Logs.info (fun m -> m "Registry path: %a" Fpath.pp registry_path);
···
171
171
(* Initialize as git repo *)
172
172
(try
173
173
let (_ : Git.Repository.t) =
174
-
Eio.Switch.run @@ fun sw ->
175
174
Git.Repository.init ~sw ~fs registry_path
176
175
in
177
176
()