forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
Add monopam fork and join commands
Implements fork/join operations for unified source management:
- fork: Split a monorepo subtree into its own repo in src/
Uses git subtree split to extract history and creates standalone repo
Updates sources.toml with origin = "fork"
- join: Bring an external repo into the monorepo as a subtree
Clones to src/ and uses git subtree add
Supports --from for joining from verse members
Updates sources.toml with origin = "join"
Also adds:
- origin type to Sources_registry for tracking source provenance
- push_ref helper to Git module
- Origin indicators (^ for fork, v:handle for join) in status output
- Fork_join module with full implementation
Co-Authored-By: Claude Opus 4.5 <noreply@anthropic.com>
+741
-20
+207
-2
bin/main.ml
+207
-2
bin/main.ml
···
115
115
let proc = Eio.Stdenv.process_mgr env in
116
116
match Monopam.status ~proc ~fs ~config () with
117
117
| Ok statuses ->
118
-
Fmt.pr "%a" Monopam.Status.pp_summary statuses;
118
+
(* Load sources.toml for origin indicators *)
119
+
let sources =
120
+
let mono_path = Monopam.Config.Paths.monorepo config in
121
+
let sources_path = Fpath.(mono_path / "sources.toml") in
122
+
match Monopam.Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path with
123
+
| Ok s -> Some s
124
+
| Error _ -> None
125
+
in
126
+
Fmt.pr "%a" (Monopam.Status.pp_summary ?sources) statuses;
119
127
(* Check for unregistered opam files *)
120
128
(match Monopam.discover_packages ~fs ~config () with
121
129
| Ok pkgs ->
···
782
790
upstream = Some result.upstream_url;
783
791
branch = None;
784
792
reason = Some (Fmt.str "Forked from %s" result.source_handle);
793
+
origin = Some Join; (* Forked from verse = joined *)
785
794
} in
786
795
let sources = Monopam.Sources_registry.add sources ~subtree:result.subtree_name entry in
787
796
(match Monopam.Sources_registry.save ~fs:(fs :> _ Eio.Path.t) sources_path sources with
···
1459
1468
in
1460
1469
Cmd.v info Term.(ret (const run $ path_arg $ url_arg $ logging_term))
1461
1470
1471
+
(* Fork command *)
1472
+
1473
+
let fork_cmd =
1474
+
let doc = "Fork a monorepo subtree into its own repository" in
1475
+
let man =
1476
+
[
1477
+
`S Manpage.s_description;
1478
+
`P
1479
+
"Splits a monorepo subdirectory into its own git repository. This \
1480
+
extracts the commit history for the subtree and creates a standalone \
1481
+
repository in src/<name>/.";
1482
+
`S "WHAT IT DOES";
1483
+
`P "The fork command:";
1484
+
`I ("1.", "Validates mono/<name>/ exists as a subtree");
1485
+
`I ("2.", "Uses $(b,git subtree split) to extract history");
1486
+
`I ("3.", "Creates a new git repo at src/<name>/");
1487
+
`I ("4.", "Pushes the extracted history to the new repo");
1488
+
`I ("5.", "Updates sources.toml with $(b,origin = \"fork\")");
1489
+
`I ("6.", "Auto-discovers packages from .opam files");
1490
+
`S "AFTER FORKING";
1491
+
`P "After forking, the subtree will be tracked via src/<name>/:";
1492
+
`I ("1.", "Make changes in mono/<name>/ as usual");
1493
+
`I ("2.", "Run $(b,monopam sync) to push changes to src/<name>/");
1494
+
`I ("3.", "If you provided a URL, push to remote: $(b,cd src/<name> && git push)");
1495
+
`S Manpage.s_examples;
1496
+
`P "Fork a subtree with local-only repo:";
1497
+
`Pre "monopam fork my-lib";
1498
+
`P "Fork with a remote push URL:";
1499
+
`Pre "monopam fork my-lib git@github.com:me/my-lib.git";
1500
+
`P "Preview what would be done:";
1501
+
`Pre "monopam fork my-lib --dry-run";
1502
+
]
1503
+
in
1504
+
let info = Cmd.info "fork" ~doc ~man in
1505
+
let name_arg =
1506
+
let doc = "Name of the subtree to fork (directory name under mono/)" in
1507
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"NAME" ~doc)
1508
+
in
1509
+
let url_arg =
1510
+
let doc = "Optional remote URL to add as 'origin' for pushing" in
1511
+
Arg.(value & pos 1 (some string) None & info [] ~docv:"URL" ~doc)
1512
+
in
1513
+
let dry_run_arg =
1514
+
let doc = "Show what would be done without making changes" in
1515
+
Arg.(value & flag & info [ "dry-run"; "n" ] ~doc)
1516
+
in
1517
+
let run name url dry_run () =
1518
+
Eio_main.run @@ fun env ->
1519
+
with_verse_config env @@ fun config ->
1520
+
let fs = Eio.Stdenv.fs env in
1521
+
let proc = Eio.Stdenv.process_mgr env in
1522
+
match Monopam.Fork_join.fork ~proc ~fs ~config ~name ?push_url:url ~dry_run () with
1523
+
| Ok result ->
1524
+
if dry_run then begin
1525
+
Fmt.pr "Would fork subtree '%s':@." result.name;
1526
+
Fmt.pr " Packages: %a@." Fmt.(list ~sep:(any ", ") string) result.packages_created;
1527
+
Fmt.pr " Destination: %a@." Fpath.pp result.src_path;
1528
+
match url with
1529
+
| Some u -> Fmt.pr " Push URL: %s@." u
1530
+
| None -> ()
1531
+
end else begin
1532
+
Fmt.pr "%a@." Monopam.Fork_join.pp_fork_result result;
1533
+
Fmt.pr "@.Next steps:@.";
1534
+
Fmt.pr " 1. Review the new repo: cd src/%s@." result.name;
1535
+
match url with
1536
+
| Some _ -> Fmt.pr " 2. Push to remote: git push -u origin main@."
1537
+
| None -> Fmt.pr " 2. Add a remote: git remote add origin <url>@."
1538
+
end;
1539
+
`Ok ()
1540
+
| Error e ->
1541
+
Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e;
1542
+
`Error (false, "fork failed")
1543
+
in
1544
+
Cmd.v info Term.(ret (const run $ name_arg $ url_arg $ dry_run_arg $ logging_term))
1545
+
1546
+
(* Join command *)
1547
+
1548
+
let join_cmd =
1549
+
let doc = "Bring an external repository into the monorepo" in
1550
+
let man =
1551
+
[
1552
+
`S Manpage.s_description;
1553
+
`P
1554
+
"Clones an external git repository and adds it as a subtree in the \
1555
+
monorepo. This is the inverse of $(b,monopam fork).";
1556
+
`S "WHAT IT DOES";
1557
+
`P "The join command:";
1558
+
`I ("1.", "Derives subtree name from URL (or uses --as)");
1559
+
`I ("2.", "Validates mono/<name>/ does not exist");
1560
+
`I ("3.", "Clones the repository to src/<name>/");
1561
+
`I ("4.", "Uses $(b,git subtree add) to bring into monorepo");
1562
+
`I ("5.", "Updates sources.toml with $(b,origin = \"join\")");
1563
+
`I ("6.", "Auto-discovers packages from .opam files");
1564
+
`S "JOINING FROM VERSE";
1565
+
`P "To join a package from a verse member, use $(b,--from):";
1566
+
`Pre "monopam join --from avsm.bsky.social --url git@github.com:me/cohttp.git cohttp";
1567
+
`P "This will:";
1568
+
`I ("-", "Look up the package in their opam-repo");
1569
+
`I ("-", "Find all packages from the same git repository");
1570
+
`I ("-", "Create opam entries pointing to your fork");
1571
+
`I ("-", "Clone and add the subtree");
1572
+
`S "AFTER JOINING";
1573
+
`P "After joining, work with the subtree normally:";
1574
+
`I ("1.", "Make changes in mono/<name>/");
1575
+
`I ("2.", "Commit in mono/");
1576
+
`I ("3.", "Run $(b,monopam sync --remote) to push upstream");
1577
+
`S Manpage.s_examples;
1578
+
`P "Join a repository:";
1579
+
`Pre "monopam join https://github.com/someone/some-lib";
1580
+
`P "Join with a custom name:";
1581
+
`Pre "monopam join https://github.com/someone/some-lib --as my-lib";
1582
+
`P "Join with upstream tracking (for forks):";
1583
+
`Pre "monopam join https://github.com/me/cohttp --upstream https://github.com/mirage/cohttp";
1584
+
`P "Join from a verse member:";
1585
+
`Pre "monopam join cohttp --from avsm.bsky.social --url git@github.com:me/cohttp.git";
1586
+
`P "Preview what would be done:";
1587
+
`Pre "monopam join https://github.com/someone/lib --dry-run";
1588
+
]
1589
+
in
1590
+
let info = Cmd.info "join" ~doc ~man in
1591
+
let url_or_pkg_arg =
1592
+
let doc = "Git URL to join, or package name (with --from)" in
1593
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"URL|PACKAGE" ~doc)
1594
+
in
1595
+
let as_arg =
1596
+
let doc = "Override subtree directory name" in
1597
+
Arg.(value & opt (some string) None & info [ "as" ] ~docv:"NAME" ~doc)
1598
+
in
1599
+
let upstream_arg =
1600
+
let doc = "Original upstream URL (for tracking forks)" in
1601
+
Arg.(value & opt (some string) None & info [ "upstream" ] ~docv:"URL" ~doc)
1602
+
in
1603
+
let from_arg =
1604
+
let doc = "Verse member handle to join from (requires --url)" in
1605
+
Arg.(value & opt (some string) None & info [ "from" ] ~docv:"HANDLE" ~doc)
1606
+
in
1607
+
let fork_url_arg =
1608
+
let doc = "Your fork URL (required with --from)" in
1609
+
Arg.(value & opt (some string) None & info [ "url" ] ~docv:"URL" ~doc)
1610
+
in
1611
+
let dry_run_arg =
1612
+
let doc = "Show what would be done without making changes" in
1613
+
Arg.(value & flag & info [ "dry-run"; "n" ] ~doc)
1614
+
in
1615
+
let run url_or_pkg as_name upstream from fork_url dry_run () =
1616
+
Eio_main.run @@ fun env ->
1617
+
with_verse_config env @@ fun config ->
1618
+
let fs = Eio.Stdenv.fs env in
1619
+
let proc = Eio.Stdenv.process_mgr env in
1620
+
match from with
1621
+
| Some handle ->
1622
+
(* Join from verse member *)
1623
+
(match fork_url with
1624
+
| None ->
1625
+
Fmt.epr "Error: --url is required when using --from@.";
1626
+
`Error (false, "--url required")
1627
+
| Some fork_url ->
1628
+
match Monopam.Fork_join.join_from_verse ~proc ~fs ~config ~verse_config:config
1629
+
~package:url_or_pkg ~handle ~fork_url ~dry_run () with
1630
+
| Ok result ->
1631
+
if dry_run then begin
1632
+
Fmt.pr "Would join '%s' from %s:@." result.name (Option.value ~default:"verse" result.from_handle);
1633
+
Fmt.pr " Source: %s@." result.source_url;
1634
+
Option.iter (fun u -> Fmt.pr " Upstream: %s@." u) result.upstream_url;
1635
+
Fmt.pr " Packages: %a@." Fmt.(list ~sep:(any ", ") string) result.packages_added
1636
+
end else begin
1637
+
Fmt.pr "%a@." Monopam.Fork_join.pp_join_result result;
1638
+
Fmt.pr "@.Next steps:@.";
1639
+
Fmt.pr " 1. Commit the opam changes: cd opam-repo && git add -A && git commit@.";
1640
+
Fmt.pr " 2. Run $(b,monopam sync) to synchronize@."
1641
+
end;
1642
+
`Ok ()
1643
+
| Error e ->
1644
+
Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e;
1645
+
`Error (false, "join failed"))
1646
+
| None ->
1647
+
(* Normal join from URL *)
1648
+
match Monopam.Fork_join.join ~proc ~fs ~config ~url:url_or_pkg ?name:as_name ?upstream ~dry_run () with
1649
+
| Ok result ->
1650
+
if dry_run then begin
1651
+
Fmt.pr "Would join '%s':@." result.name;
1652
+
Fmt.pr " Source: %s@." result.source_url;
1653
+
Option.iter (fun u -> Fmt.pr " Upstream: %s@." u) result.upstream_url;
1654
+
Fmt.pr " Packages: %a@." Fmt.(list ~sep:(any ", ") string) result.packages_added
1655
+
end else begin
1656
+
Fmt.pr "%a@." Monopam.Fork_join.pp_join_result result;
1657
+
Fmt.pr "@.Next steps:@.";
1658
+
Fmt.pr " 1. Run $(b,monopam sync) to synchronize@."
1659
+
end;
1660
+
`Ok ()
1661
+
| Error e ->
1662
+
Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e;
1663
+
`Error (false, "join failed")
1664
+
in
1665
+
Cmd.v info Term.(ret (const run $ url_or_pkg_arg $ as_arg $ upstream_arg $ from_arg $ fork_url_arg $ dry_run_arg $ logging_term))
1666
+
1462
1667
(* Main command group *)
1463
1668
1464
1669
let main_cmd =
···
1561
1766
in
1562
1767
let info = Cmd.info "monopam" ~version:"%%VERSION%%" ~doc ~man in
1563
1768
Cmd.group info
1564
-
[ status_cmd; diff_cmd; pull_cmd; cherrypick_cmd; sync_cmd; changes_cmd; opam_cmd; doctor_cmd; verse_cmd; feature_cmd; devcontainer_cmd ]
1769
+
[ status_cmd; diff_cmd; pull_cmd; cherrypick_cmd; sync_cmd; changes_cmd; opam_cmd; doctor_cmd; verse_cmd; feature_cmd; fork_cmd; join_cmd; devcontainer_cmd ]
1565
1770
1566
1771
let () = exit (Cmd.eval main_cmd)
+1
-1
lib/doctor.ml
+1
-1
lib/doctor.ml
···
436
436
Buffer.add_string buf "## Current Monorepo Status\n\n";
437
437
Buffer.add_string buf "Output of `monopam status`:\n```\n";
438
438
(* Capture formatted pp_summary output (strip ANSI codes for prompt) *)
439
-
let fmt_output = Fmt.str "%a" Status.pp_summary statuses in
439
+
let fmt_output = Fmt.str "%a" (Status.pp_summary ?sources:None) statuses in
440
440
Buffer.add_string buf (strip_ansi fmt_output);
441
441
Buffer.add_string buf "```\n\n";
442
442
Buffer.add_string buf "Detailed status per repository:\n";
+279
lib/fork_join.ml
+279
lib/fork_join.ml
···
1
+
(** Fork and join operations for managing monorepo sources. *)
2
+
3
+
type error =
4
+
| Config_error of string
5
+
| Git_error of Git.error
6
+
| Subtree_not_found of string
7
+
| Src_already_exists of string
8
+
| Subtree_already_exists of string
9
+
| No_opam_files of string
10
+
| Verse_error of Verse.error
11
+
12
+
let pp_error ppf = function
13
+
| Config_error msg -> Fmt.pf ppf "Configuration error: %s" msg
14
+
| Git_error e -> Fmt.pf ppf "Git error: %a" Git.pp_error e
15
+
| Subtree_not_found name -> Fmt.pf ppf "Subtree not found in monorepo: %s" name
16
+
| Src_already_exists name -> Fmt.pf ppf "Source checkout already exists: src/%s" name
17
+
| Subtree_already_exists name -> Fmt.pf ppf "Subtree already exists in monorepo: mono/%s" name
18
+
| No_opam_files name -> Fmt.pf ppf "No .opam files found in subtree: %s" name
19
+
| Verse_error e -> Fmt.pf ppf "Verse error: %a" Verse.pp_error e
20
+
21
+
let error_hint = function
22
+
| Config_error _ ->
23
+
Some "Run 'monopam verse init --handle <your-handle>' to create a workspace."
24
+
| Git_error (Git.Dirty_worktree _) ->
25
+
Some "Commit or stash your changes first: git status"
26
+
| Git_error _ -> None
27
+
| Subtree_not_found name ->
28
+
Some (Fmt.str "Check that mono/%s exists in your monorepo" name)
29
+
| Src_already_exists name ->
30
+
Some (Fmt.str "Remove or rename src/%s first, or choose a different name" name)
31
+
| Subtree_already_exists name ->
32
+
Some (Fmt.str "Remove mono/%s first, or use a different name with --as" name)
33
+
| No_opam_files name ->
34
+
Some (Fmt.str "Add a .opam file to mono/%s before forking" name)
35
+
| Verse_error e -> Verse.error_hint e
36
+
37
+
let pp_error_with_hint ppf e =
38
+
pp_error ppf e;
39
+
match error_hint e with
40
+
| Some hint -> Fmt.pf ppf "@.@[<v 2>Hint: %s@]" hint
41
+
| None -> ()
42
+
43
+
type fork_result = {
44
+
name : string;
45
+
split_commit : string;
46
+
src_path : Fpath.t;
47
+
push_url : string option;
48
+
packages_created : string list;
49
+
}
50
+
51
+
type join_result = {
52
+
name : string;
53
+
source_url : string;
54
+
upstream_url : string option;
55
+
packages_added : string list;
56
+
from_handle : string option;
57
+
}
58
+
59
+
let pp_fork_result ppf (r : fork_result) =
60
+
Fmt.pf ppf "@[<v>Forked subtree '%s':@, Split commit: %s@, Local repo: %a@,"
61
+
r.name
62
+
(String.sub r.split_commit 0 (min 7 (String.length r.split_commit)))
63
+
Fpath.pp r.src_path;
64
+
(match r.push_url with
65
+
| Some url -> Fmt.pf ppf " Push URL: %s@," url
66
+
| None -> ());
67
+
if r.packages_created <> [] then
68
+
Fmt.pf ppf " Packages: %a@]" Fmt.(list ~sep:(any ", ") string) r.packages_created
69
+
else
70
+
Fmt.pf ppf "@]"
71
+
72
+
let pp_join_result ppf (r : join_result) =
73
+
Fmt.pf ppf "@[<v>Joined repository '%s':@, Source: %s@,"
74
+
r.name r.source_url;
75
+
(match r.upstream_url with
76
+
| Some url -> Fmt.pf ppf " Upstream: %s@," url
77
+
| None -> ());
78
+
(match r.from_handle with
79
+
| Some h -> Fmt.pf ppf " From verse: %s@," h
80
+
| None -> ());
81
+
if r.packages_added <> [] then
82
+
Fmt.pf ppf " Packages: %a@]" Fmt.(list ~sep:(any ", ") string) r.packages_added
83
+
else
84
+
Fmt.pf ppf "@]"
85
+
86
+
(** Helper to check if a path is a directory *)
87
+
let is_directory ~fs path =
88
+
let eio_path = Eio.Path.(fs / Fpath.to_string path) in
89
+
match Eio.Path.kind ~follow:true eio_path with
90
+
| `Directory -> true
91
+
| _ -> false
92
+
| exception _ -> false
93
+
94
+
(** Helper to create a directory if it doesn't exist *)
95
+
let ensure_dir ~fs path =
96
+
let eio_path = Eio.Path.(fs / Fpath.to_string path) in
97
+
try Eio.Path.mkdirs ~perm:0o755 eio_path with Eio.Io _ -> ()
98
+
99
+
(** Scan a directory for .opam files *)
100
+
let find_opam_files ~fs path =
101
+
let eio_path = Eio.Path.(fs / Fpath.to_string path) in
102
+
try
103
+
Eio.Path.read_dir eio_path
104
+
|> List.filter (fun name -> String.ends_with ~suffix:".opam" name)
105
+
|> List.map (fun name ->
106
+
(* Extract package name from filename.opam *)
107
+
String.sub name 0 (String.length name - 5))
108
+
with Eio.Io _ -> []
109
+
110
+
(** Extract name from URL (last path component without .git suffix) *)
111
+
let name_from_url url =
112
+
let uri = Uri.of_string url in
113
+
let path = Uri.path uri in
114
+
(* Remove leading slash and .git suffix *)
115
+
let path = if String.length path > 0 && path.[0] = '/' then
116
+
String.sub path 1 (String.length path - 1)
117
+
else path in
118
+
let path = if String.ends_with ~suffix:".git" path then
119
+
String.sub path 0 (String.length path - 4)
120
+
else path in
121
+
(* Get last component *)
122
+
match String.rindex_opt path '/' with
123
+
| Some i -> String.sub path (i + 1) (String.length path - i - 1)
124
+
| None -> path
125
+
126
+
let fork ~proc ~fs ~config ~name ?push_url ?(dry_run = false) () =
127
+
let monorepo = Verse_config.mono_path config in
128
+
let checkouts = Verse_config.src_path config in
129
+
let prefix = name in
130
+
let subtree_path = Fpath.(monorepo / prefix) in
131
+
let src_path = Fpath.(checkouts / name) in
132
+
(* Validate: mono/<name>/ must exist *)
133
+
if not (Git.Subtree.exists ~fs ~repo:monorepo ~prefix) then
134
+
Error (Subtree_not_found name)
135
+
(* Validate: src/<name>/ must not exist *)
136
+
else if is_directory ~fs src_path then
137
+
Error (Src_already_exists name)
138
+
else begin
139
+
(* Find .opam files in subtree *)
140
+
let packages = find_opam_files ~fs subtree_path in
141
+
if packages = [] then
142
+
Error (No_opam_files name)
143
+
else if dry_run then
144
+
Ok { name; split_commit = "(dry-run)"; src_path; push_url; packages_created = packages }
145
+
else begin
146
+
(* Split the subtree to get history *)
147
+
match Git.Subtree.split ~proc ~fs ~repo:monorepo ~prefix () with
148
+
| Error e -> Error (Git_error e)
149
+
| Ok split_commit ->
150
+
(* Ensure src/ exists *)
151
+
ensure_dir ~fs checkouts;
152
+
(* Initialize new git repo at src/<name>/ *)
153
+
match Git.init ~proc ~fs src_path with
154
+
| Error e -> Error (Git_error e)
155
+
| Ok () ->
156
+
(* Add 'origin' remote pointing to monorepo path temporarily *)
157
+
let mono_str = Fpath.to_string monorepo in
158
+
(match Git.add_remote ~proc ~fs ~name:"mono" ~url:mono_str src_path with
159
+
| Error e -> Error (Git_error e)
160
+
| Ok () ->
161
+
(* Push split commit to local repo *)
162
+
let ref_spec = split_commit ^ ":refs/heads/main" in
163
+
match Git.push_ref ~proc ~fs ~repo:monorepo ~target:(Fpath.to_string src_path) ~ref_spec () with
164
+
| Error e -> Error (Git_error e)
165
+
| Ok () ->
166
+
(* Checkout main branch *)
167
+
(match Git.checkout ~proc ~fs ~branch:"main" src_path with
168
+
| Error e -> Error (Git_error e)
169
+
| Ok () ->
170
+
(* Set push URL if provided *)
171
+
let push_result =
172
+
match push_url with
173
+
| Some url ->
174
+
(match Git.add_remote ~proc ~fs ~name:"origin" ~url src_path with
175
+
| Error e -> Error (Git_error e)
176
+
| Ok () -> Ok ())
177
+
| None -> Ok ()
178
+
in
179
+
match push_result with
180
+
| Error _ as e -> e
181
+
| Ok () ->
182
+
(* Update sources.toml with fork entry *)
183
+
let sources_path = Fpath.(monorepo / "sources.toml") in
184
+
let sources =
185
+
match Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path with
186
+
| Ok s -> s
187
+
| Error _ -> Sources_registry.empty
188
+
in
189
+
let url = match push_url with
190
+
| Some u -> u
191
+
| None -> "file://" ^ Fpath.to_string src_path
192
+
in
193
+
let entry = Sources_registry.{
194
+
url;
195
+
upstream = None;
196
+
branch = Some "main";
197
+
reason = Some "Forked from monorepo";
198
+
origin = Some Fork;
199
+
} in
200
+
let sources = Sources_registry.add sources ~subtree:name entry in
201
+
(match Sources_registry.save ~fs:(fs :> _ Eio.Path.t) sources_path sources with
202
+
| Ok () -> ()
203
+
| Error msg -> Logs.warn (fun m -> m "Failed to update sources.toml: %s" msg));
204
+
Ok { name; split_commit; src_path; push_url; packages_created = packages }))
205
+
end
206
+
end
207
+
208
+
let join ~proc ~fs ~config ~url ?name ?upstream ?(dry_run = false) () =
209
+
let name = match name with Some n -> n | None -> name_from_url url in
210
+
let monorepo = Verse_config.mono_path config in
211
+
let checkouts = Verse_config.src_path config in
212
+
let prefix = name in
213
+
let subtree_path = Fpath.(monorepo / prefix) in
214
+
let src_path = Fpath.(checkouts / name) in
215
+
(* Validate: mono/<name>/ must not exist *)
216
+
if Git.Subtree.exists ~fs ~repo:monorepo ~prefix then
217
+
Error (Subtree_already_exists name)
218
+
else if dry_run then
219
+
Ok { name; source_url = url; upstream_url = upstream; packages_added = []; from_handle = None }
220
+
else begin
221
+
(* Ensure src/ exists *)
222
+
ensure_dir ~fs checkouts;
223
+
(* Clone to src/<name>/ *)
224
+
let branch = Verse_config.default_branch in
225
+
let uri = Uri.of_string url in
226
+
match Git.clone ~proc ~fs ~url:uri ~branch src_path with
227
+
| Error e -> Error (Git_error e)
228
+
| Ok () ->
229
+
(* Add subtree to monorepo *)
230
+
match Git.Subtree.add ~proc ~fs ~repo:monorepo ~prefix ~url:uri ~branch () with
231
+
| Error e -> Error (Git_error e)
232
+
| Ok () ->
233
+
(* Find .opam files in the new subtree *)
234
+
let packages = find_opam_files ~fs subtree_path in
235
+
(* Update sources.toml with join entry *)
236
+
let sources_path = Fpath.(monorepo / "sources.toml") in
237
+
let sources =
238
+
match Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path with
239
+
| Ok s -> s
240
+
| Error _ -> Sources_registry.empty
241
+
in
242
+
let entry = Sources_registry.{
243
+
url;
244
+
upstream;
245
+
branch = Some branch;
246
+
reason = Some "Joined to monorepo";
247
+
origin = Some Join;
248
+
} in
249
+
let sources = Sources_registry.add sources ~subtree:name entry in
250
+
(match Sources_registry.save ~fs:(fs :> _ Eio.Path.t) sources_path sources with
251
+
| Ok () -> ()
252
+
| Error msg -> Logs.warn (fun m -> m "Failed to update sources.toml: %s" msg));
253
+
Ok { name; source_url = url; upstream_url = upstream; packages_added = packages; from_handle = None }
254
+
end
255
+
256
+
let join_from_verse ~proc ~fs ~config ~verse_config ~package ~handle ~fork_url ?(dry_run = false) () =
257
+
(* First use verse fork to set up the opam entries *)
258
+
match Verse.fork ~proc ~fs ~config:verse_config ~handle ~package ~fork_url ~dry_run () with
259
+
| Error e -> Error (Verse_error e)
260
+
| Ok fork_result ->
261
+
if dry_run then
262
+
Ok {
263
+
name = fork_result.subtree_name;
264
+
source_url = fork_url;
265
+
upstream_url = Some fork_result.upstream_url;
266
+
packages_added = fork_result.packages_forked;
267
+
from_handle = Some handle;
268
+
}
269
+
else begin
270
+
(* Now join the repository *)
271
+
let name = fork_result.subtree_name in
272
+
match join ~proc ~fs ~config ~url:fork_url ~name ~upstream:fork_result.upstream_url ~dry_run () with
273
+
| Error e -> Error e
274
+
| Ok join_result ->
275
+
Ok { join_result with
276
+
packages_added = fork_result.packages_forked;
277
+
from_handle = Some handle;
278
+
}
279
+
end
+132
lib/fork_join.mli
+132
lib/fork_join.mli
···
1
+
(** Fork and join operations for managing monorepo sources.
2
+
3
+
This module provides operations to:
4
+
- Fork: Split a monorepo subtree into its own repository in src/
5
+
- Join: Bring an external repository into the monorepo as a subtree
6
+
7
+
Both operations update sources.toml to track the origin of each source. *)
8
+
9
+
(** {1 Error Types} *)
10
+
11
+
type error =
12
+
| Config_error of string (** Configuration error *)
13
+
| Git_error of Git.error (** Git operation failed *)
14
+
| Subtree_not_found of string (** Subtree not found in monorepo *)
15
+
| Src_already_exists of string (** Source checkout already exists *)
16
+
| Subtree_already_exists of string (** Subtree already exists in monorepo *)
17
+
| No_opam_files of string (** No .opam files found in subtree *)
18
+
| Verse_error of Verse.error (** Error from verse operations *)
19
+
20
+
val pp_error : error Fmt.t
21
+
(** [pp_error] formats errors. *)
22
+
23
+
val pp_error_with_hint : error Fmt.t
24
+
(** [pp_error_with_hint] formats errors with helpful hints. *)
25
+
26
+
val error_hint : error -> string option
27
+
(** [error_hint e] returns a hint string for the given error, if available. *)
28
+
29
+
(** {1 Fork Operations} *)
30
+
31
+
(** Result of a fork operation. *)
32
+
type fork_result = {
33
+
name : string; (** Subtree/repository name *)
34
+
split_commit : string; (** Git commit SHA from subtree split *)
35
+
src_path : Fpath.t; (** Path to the new source checkout *)
36
+
push_url : string option; (** Remote push URL if provided *)
37
+
packages_created : string list; (** Package names from .opam files *)
38
+
}
39
+
40
+
val pp_fork_result : fork_result Fmt.t
41
+
(** [pp_fork_result] formats a fork result. *)
42
+
43
+
val fork :
44
+
proc:_ Eio.Process.mgr ->
45
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
46
+
config:Verse_config.t ->
47
+
name:string ->
48
+
?push_url:string ->
49
+
?dry_run:bool ->
50
+
unit ->
51
+
(fork_result, error) result
52
+
(** [fork ~proc ~fs ~config ~name ?push_url ?dry_run ()] splits a monorepo
53
+
subtree into its own repository.
54
+
55
+
This operation:
56
+
1. Validates mono/<name>/ exists
57
+
2. Validates src/<name>/ does not exist
58
+
3. Uses [git subtree split] to extract history
59
+
4. Creates a new git repo at src/<name>/
60
+
5. Pushes the split commit to the new repo
61
+
6. Updates sources.toml with [origin = "fork"]
62
+
7. Auto-discovers packages from .opam files
63
+
64
+
@param name Name of the subtree to fork (directory name under mono/)
65
+
@param push_url Optional remote URL to add as origin for pushing
66
+
@param dry_run If true, validate and report what would be done *)
67
+
68
+
(** {1 Join Operations} *)
69
+
70
+
(** Result of a join operation. *)
71
+
type join_result = {
72
+
name : string; (** Subtree/repository name *)
73
+
source_url : string; (** URL the repository was cloned from *)
74
+
upstream_url : string option; (** Original upstream if this is a fork *)
75
+
packages_added : string list; (** Package names from .opam files *)
76
+
from_handle : string option; (** Verse handle if joined from verse *)
77
+
}
78
+
79
+
val pp_join_result : join_result Fmt.t
80
+
(** [pp_join_result] formats a join result. *)
81
+
82
+
val join :
83
+
proc:_ Eio.Process.mgr ->
84
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
85
+
config:Verse_config.t ->
86
+
url:string ->
87
+
?name:string ->
88
+
?upstream:string ->
89
+
?dry_run:bool ->
90
+
unit ->
91
+
(join_result, error) result
92
+
(** [join ~proc ~fs ~config ~url ?name ?upstream ?dry_run ()] brings an external
93
+
repository into the monorepo.
94
+
95
+
This operation:
96
+
1. Derives name from URL if not provided
97
+
2. Validates mono/<name>/ does not exist
98
+
3. Clones the repository to src/<name>/
99
+
4. Uses [git subtree add] to bring into monorepo
100
+
5. Updates sources.toml with [origin = "join"]
101
+
6. Auto-discovers packages from .opam files
102
+
103
+
@param url Git URL to clone from
104
+
@param name Override the subtree directory name (default: derived from URL)
105
+
@param upstream Original upstream URL if this is your fork of another project
106
+
@param dry_run If true, validate and report what would be done *)
107
+
108
+
val join_from_verse :
109
+
proc:_ Eio.Process.mgr ->
110
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
111
+
config:Verse_config.t ->
112
+
verse_config:Verse_config.t ->
113
+
package:string ->
114
+
handle:string ->
115
+
fork_url:string ->
116
+
?dry_run:bool ->
117
+
unit ->
118
+
(join_result, error) result
119
+
(** [join_from_verse ~proc ~fs ~config ~verse_config ~package ~handle ~fork_url
120
+
?dry_run ()] joins a package from a verse member's repository.
121
+
122
+
This combines [Verse.fork] (to set up opam entries) with [join]:
123
+
1. Looks up the package in verse/<handle>-opam/
124
+
2. Finds all packages sharing the same git repository
125
+
3. Creates opam entries pointing to your fork
126
+
4. Clones and adds the subtree
127
+
128
+
@param verse_config Verse configuration (for accessing verse/ directory)
129
+
@param package Package name to look up
130
+
@param handle Verse member handle (e.g., "avsm.bsky.social")
131
+
@param fork_url Your fork URL
132
+
@param dry_run If true, validate and report what would be done *)
+4
lib/git.ml
+4
lib/git.ml
···
272
272
in
273
273
run_git_ok_with_retry ~proc ~cwd [ "push"; remote; branch ] |> Result.map ignore
274
274
275
+
let push_ref ~proc ~fs ~repo ~target ~ref_spec () =
276
+
let cwd = path_to_eio ~fs repo in
277
+
run_git_ok ~proc ~cwd [ "push"; target; ref_spec ] |> Result.map ignore
278
+
275
279
let set_push_url ~proc ~fs ?(remote = "origin") ~url path =
276
280
let cwd = path_to_eio ~fs path in
277
281
run_git_ok ~proc ~cwd [ "remote"; "set-url"; "--push"; remote; url ]
+15
lib/git.mli
+15
lib/git.mli
···
274
274
@param remote Remote name (default: "origin")
275
275
@param branch Branch to push (default: current branch) *)
276
276
277
+
val push_ref :
278
+
proc:_ Eio.Process.mgr ->
279
+
fs:Eio.Fs.dir_ty Eio.Path.t ->
280
+
repo:Fpath.t ->
281
+
target:string ->
282
+
ref_spec:string ->
283
+
unit ->
284
+
(unit, error) result
285
+
(** [push_ref ~proc ~fs ~repo ~target ~ref_spec ()] pushes a specific ref to a
286
+
target repository or path.
287
+
288
+
@param repo Path to the git repository to push from
289
+
@param target Target repository path or remote name
290
+
@param ref_spec The refspec to push (e.g., "abc123:refs/heads/main") *)
291
+
277
292
val set_push_url :
278
293
proc:_ Eio.Process.mgr ->
279
294
fs:Eio.Fs.dir_ty Eio.Path.t ->
+1
lib/monopam.ml
+1
lib/monopam.ml
+1
lib/monopam.mli
+1
lib/monopam.mli
+19
-1
lib/sources_registry.ml
+19
-1
lib/sources_registry.ml
···
1
1
(** Sources registry for tracking forked/vendored package URLs. *)
2
2
3
+
type origin = Fork | Join
4
+
3
5
type entry = {
4
6
url : string;
5
7
upstream : string option;
6
8
branch : string option;
7
9
reason : string option;
10
+
origin : origin option;
8
11
}
9
12
10
13
type t = {
···
58
61
branch = "backport-5.1"
59
62
*)
60
63
64
+
let origin_codec : origin Tomlt.t =
65
+
Tomlt.map
66
+
~dec:(function
67
+
| "fork" -> Fork
68
+
| "join" -> Join
69
+
| s -> failwith (Printf.sprintf "Invalid origin: %s (expected 'fork' or 'join')" s))
70
+
~enc:(function Fork -> "fork" | Join -> "join")
71
+
Tomlt.string
72
+
61
73
let entry_codec : entry Tomlt.t =
62
74
Tomlt.(
63
75
Table.(
64
-
obj (fun url upstream branch reason -> { url; upstream; branch; reason })
76
+
obj (fun url upstream branch reason origin -> { url; upstream; branch; reason; origin })
65
77
|> mem "url" string ~enc:(fun e -> e.url)
66
78
|> opt_mem "upstream" string ~enc:(fun e -> e.upstream)
67
79
|> opt_mem "branch" string ~enc:(fun e -> e.branch)
68
80
|> opt_mem "reason" string ~enc:(fun e -> e.reason)
81
+
|> opt_mem "origin" origin_codec ~enc:(fun e -> e.origin)
69
82
|> finish))
70
83
71
84
let codec : t Tomlt.t =
···
96
109
Ok ()
97
110
with exn -> Error (Printexc.to_string exn)
98
111
112
+
let pp_origin ppf = function
113
+
| Fork -> Fmt.string ppf "fork"
114
+
| Join -> Fmt.string ppf "join"
115
+
99
116
let pp_entry ppf e =
100
117
Fmt.pf ppf "@[<hov 2>url: %s" e.url;
101
118
Option.iter (fun u -> Fmt.pf ppf "@ upstream: %s" u) e.upstream;
102
119
Option.iter (fun b -> Fmt.pf ppf "@ branch: %s" b) e.branch;
103
120
Option.iter (fun r -> Fmt.pf ppf "@ reason: %s" r) e.reason;
121
+
Option.iter (fun o -> Fmt.pf ppf "@ origin: %a" pp_origin o) e.origin;
104
122
Fmt.pf ppf "@]"
105
123
106
124
let pp ppf t =
+6
lib/sources_registry.mli
+6
lib/sources_registry.mli
···
15
15
For a subtree named "ocaml-foo", this would produce:
16
16
[git+https://tangled.org/anil.recoil.org/ocaml-foo] *)
17
17
18
+
(** How a source entry was created. *)
19
+
type origin =
20
+
| Fork (** Created via [monopam fork] - subtree split from monorepo *)
21
+
| Join (** Created via [monopam join] - external repo brought into monorepo *)
22
+
18
23
(** A source entry for a subtree. *)
19
24
type entry = {
20
25
url : string; (** Our dev-repo URL (e.g., "git+https://github.com/avsm/braid") *)
21
26
upstream : string option; (** Original upstream URL if this is a fork *)
22
27
branch : string option; (** Override branch (default: main) *)
23
28
reason : string option; (** Why we have a custom source *)
29
+
origin : origin option; (** How this entry was created *)
24
30
}
25
31
26
32
(** The sources registry - maps subtree names to source entries. *)
+69
-14
lib/status.ml
+69
-14
lib/status.ml
···
160
160
Fmt.pf ppf "@[<h>%-20s checkout: %a subtree: %a@]" (Package.name t.package)
161
161
pp_checkout_status t.checkout pp_subtree_status t.subtree
162
162
163
+
(** Extract handle from a tangled.org URL like "git+https://tangled.org/handle/repo" *)
164
+
let extract_handle_from_url url =
165
+
let url = if String.starts_with ~prefix:"git+" url then
166
+
String.sub url 4 (String.length url - 4)
167
+
else url in
168
+
let uri = Uri.of_string url in
169
+
match Uri.host uri with
170
+
| Some "tangled.org" ->
171
+
let path = Uri.path uri in
172
+
(* Path is like "/handle/repo" - extract first component *)
173
+
let path = if String.length path > 0 && path.[0] = '/' then
174
+
String.sub path 1 (String.length path - 1)
175
+
else path in
176
+
(match String.index_opt path '/' with
177
+
| Some i -> Some (String.sub path 0 i)
178
+
| None -> Some path)
179
+
| _ -> None
180
+
181
+
(** Format origin indicator from sources registry entry *)
182
+
let pp_origin_indicator ppf entry =
183
+
match entry with
184
+
| None -> ()
185
+
| Some Sources_registry.{ origin = Some Sources_registry.Fork; _ } ->
186
+
Fmt.pf ppf " %a" Fmt.(styled `Magenta string) "^"
187
+
| Some Sources_registry.{ origin = Some Sources_registry.Join; upstream = Some url; _ } ->
188
+
(match extract_handle_from_url url with
189
+
| Some handle ->
190
+
(* Abbreviate handle - take first part before dot, max 8 chars *)
191
+
let abbrev = match String.index_opt handle '.' with
192
+
| Some i -> String.sub handle 0 i
193
+
| None -> handle
194
+
in
195
+
let abbrev = if String.length abbrev > 8 then String.sub abbrev 0 8 else abbrev in
196
+
Fmt.pf ppf " %a" Fmt.(styled `Cyan (fun ppf s -> pf ppf "v:%s" s)) abbrev
197
+
| None -> Fmt.pf ppf " %a" Fmt.(styled `Cyan string) "v:")
198
+
| Some Sources_registry.{ origin = Some Sources_registry.Join; _ } ->
199
+
Fmt.pf ppf " %a" Fmt.(styled `Cyan string) "v:"
200
+
| Some _ -> ()
201
+
163
202
(** Compact status for actionable items with colors *)
164
-
let pp_compact ppf t =
203
+
let pp_compact ?sources ppf t =
165
204
let name = Package.name t.package in
205
+
let subtree = Package.subtree_prefix t.package in
206
+
let entry = match sources with
207
+
| Some s -> Sources_registry.find s ~subtree
208
+
| None -> None
209
+
in
166
210
(* Helper to print remote sync info *)
167
211
let pp_remote ab =
168
212
if ab.Git.ahead > 0 && ab.behind > 0 then
···
184
228
Fmt.pf ppf "%-22s %a" name
185
229
Fmt.(styled `Blue (fun ppf n -> pf ppf "local:-%d" n))
186
230
n;
187
-
pp_remote ab
231
+
pp_remote ab;
232
+
pp_origin_indicator ppf entry
188
233
| Clean ab, Present, Subtree_ahead n ->
189
234
Fmt.pf ppf "%-22s %a" name
190
235
Fmt.(styled `Blue (fun ppf n -> pf ppf "local:+%d" n))
191
236
n;
192
-
pp_remote ab
237
+
pp_remote ab;
238
+
pp_origin_indicator ppf entry
193
239
(* Trees differ but can't determine count *)
194
240
| Clean ab, Present, Trees_differ ->
195
241
Fmt.pf ppf "%-22s %a" name Fmt.(styled `Blue string) "local:sync";
196
-
pp_remote ab
242
+
pp_remote ab;
243
+
pp_origin_indicator ppf entry
197
244
(* Remote sync issues only *)
198
245
| Clean ab, Present, (In_sync | Unknown) when ab.ahead > 0 && ab.behind > 0 ->
199
246
Fmt.pf ppf "%-22s %a" name
200
247
Fmt.(styled `Yellow (fun ppf (a, b) -> pf ppf "remote:+%d/-%d" a b))
201
-
(ab.ahead, ab.behind)
248
+
(ab.ahead, ab.behind);
249
+
pp_origin_indicator ppf entry
202
250
| Clean ab, Present, (In_sync | Unknown) when ab.ahead > 0 ->
203
251
Fmt.pf ppf "%-22s %a" name
204
252
Fmt.(styled `Cyan (fun ppf n -> pf ppf "remote:+%d" n))
205
-
ab.ahead
253
+
ab.ahead;
254
+
pp_origin_indicator ppf entry
206
255
| Clean ab, Present, (In_sync | Unknown) when ab.behind > 0 ->
207
256
Fmt.pf ppf "%-22s %a" name
208
257
Fmt.(styled `Red (fun ppf n -> pf ppf "remote:-%d" n))
209
-
ab.behind
258
+
ab.behind;
259
+
pp_origin_indicator ppf entry
210
260
(* Other issues *)
211
261
| Clean _, Not_added, _ ->
212
-
Fmt.pf ppf "%-22s %a" name Fmt.(styled `Magenta string) "(no subtree)"
262
+
Fmt.pf ppf "%-22s %a" name Fmt.(styled `Magenta string) "(no subtree)";
263
+
pp_origin_indicator ppf entry
213
264
| Missing, _, _ ->
214
-
Fmt.pf ppf "%-22s %a" name Fmt.(styled `Red string) "(no checkout)"
265
+
Fmt.pf ppf "%-22s %a" name Fmt.(styled `Red string) "(no checkout)";
266
+
pp_origin_indicator ppf entry
215
267
| Not_a_repo, _, _ ->
216
-
Fmt.pf ppf "%-22s %a" name Fmt.(styled `Red string) "(not a repo)"
268
+
Fmt.pf ppf "%-22s %a" name Fmt.(styled `Red string) "(not a repo)";
269
+
pp_origin_indicator ppf entry
217
270
| Dirty, _, _ ->
218
-
Fmt.pf ppf "%-22s %a" name Fmt.(styled `Yellow string) "(dirty)"
271
+
Fmt.pf ppf "%-22s %a" name Fmt.(styled `Yellow string) "(dirty)";
272
+
pp_origin_indicator ppf entry
219
273
| Clean _, Present, (In_sync | Unknown) ->
220
-
Fmt.pf ppf "%-22s %a" name Fmt.(styled `Green string) "ok"
274
+
Fmt.pf ppf "%-22s %a" name Fmt.(styled `Green string) "ok";
275
+
pp_origin_indicator ppf entry
221
276
222
-
let pp_summary ppf statuses =
277
+
let pp_summary ?sources ppf statuses =
223
278
let total = List.length statuses in
224
279
let actionable = filter_actionable statuses in
225
280
let synced = List.filter is_fully_synced statuses |> List.length in
···
258
313
"all synced";
259
314
(* Only show actionable items *)
260
315
if actionable <> [] then
261
-
List.iter (fun t -> Fmt.pf ppf " %a\n" pp_compact t) actionable
316
+
List.iter (fun t -> Fmt.pf ppf " %a\n" (pp_compact ?sources) t) actionable
+7
-2
lib/status.mli
+7
-2
lib/status.mli
···
112
112
val pp : t Fmt.t
113
113
(** [pp] formats a single package status. *)
114
114
115
-
val pp_summary : t list Fmt.t
116
-
(** [pp_summary] formats a summary of all package statuses. *)
115
+
val pp_compact : ?sources:Sources_registry.t -> t Fmt.t
116
+
(** [pp_compact ?sources] formats a single package status in compact form with colors.
117
+
If [sources] is provided, displays origin indicators (^ for fork, v:handle for join). *)
118
+
119
+
val pp_summary : ?sources:Sources_registry.t -> t list Fmt.t
120
+
(** [pp_summary ?sources] formats a summary of all package statuses.
121
+
If [sources] is provided, displays origin indicators for each package. *)