My aggregated monorepo of OCaml code, automaintained
Squashed 'monopam/' changes from 9407fff..d0cac4f
d0cac4f merge
280b9b6 fix fork handling
b0e996b Fix monopam join --url flag to work for simple joins
66a4f79 Add monopam fork and join commands
git-subtree-dir: monopam
git-subtree-split: d0cac4fe0239d49d6abf73bc95e96709ad555cb7
+755
-20
+211
-2
bin/main.ml
+211
-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 explicit name using --url:";
1581
+
`Pre "monopam join --url https://tangled.org/handle/sortal sortal";
1582
+
`P "Join with a custom name using --as:";
1583
+
`Pre "monopam join https://github.com/someone/some-lib --as my-lib";
1584
+
`P "Join with upstream tracking (for forks):";
1585
+
`Pre "monopam join https://github.com/me/cohttp --upstream https://github.com/mirage/cohttp";
1586
+
`P "Join from a verse member:";
1587
+
`Pre "monopam join cohttp --from avsm.bsky.social --url git@github.com:me/cohttp.git";
1588
+
`P "Preview what would be done:";
1589
+
`Pre "monopam join https://github.com/someone/lib --dry-run";
1590
+
]
1591
+
in
1592
+
let info = Cmd.info "join" ~doc ~man in
1593
+
let url_or_pkg_arg =
1594
+
let doc = "Git URL to join, or subtree name (when using --url)" in
1595
+
Arg.(required & pos 0 (some string) None & info [] ~docv:"URL|NAME" ~doc)
1596
+
in
1597
+
let as_arg =
1598
+
let doc = "Override subtree directory name" in
1599
+
Arg.(value & opt (some string) None & info [ "as" ] ~docv:"NAME" ~doc)
1600
+
in
1601
+
let upstream_arg =
1602
+
let doc = "Original upstream URL (for tracking forks)" in
1603
+
Arg.(value & opt (some string) None & info [ "upstream" ] ~docv:"URL" ~doc)
1604
+
in
1605
+
let from_arg =
1606
+
let doc = "Verse member handle to join from (requires --url)" in
1607
+
Arg.(value & opt (some string) None & info [ "from" ] ~docv:"HANDLE" ~doc)
1608
+
in
1609
+
let fork_url_arg =
1610
+
let doc = "Git URL to clone from (makes positional arg the subtree name)" in
1611
+
Arg.(value & opt (some string) None & info [ "url" ] ~docv:"URL" ~doc)
1612
+
in
1613
+
let dry_run_arg =
1614
+
let doc = "Show what would be done without making changes" in
1615
+
Arg.(value & flag & info [ "dry-run"; "n" ] ~doc)
1616
+
in
1617
+
let run url_or_pkg as_name upstream from fork_url dry_run () =
1618
+
Eio_main.run @@ fun env ->
1619
+
with_verse_config env @@ fun config ->
1620
+
let fs = Eio.Stdenv.fs env in
1621
+
let proc = Eio.Stdenv.process_mgr env in
1622
+
match from with
1623
+
| Some handle ->
1624
+
(* Join from verse member - requires --url for your fork *)
1625
+
(match fork_url with
1626
+
| None ->
1627
+
Fmt.epr "Error: --url is required when using --from@.";
1628
+
`Error (false, "--url required")
1629
+
| Some fork_url ->
1630
+
match Monopam.Fork_join.join_from_verse ~proc ~fs ~config ~verse_config:config
1631
+
~package:url_or_pkg ~handle ~fork_url ~dry_run () with
1632
+
| Ok result ->
1633
+
if dry_run then begin
1634
+
Fmt.pr "Would join '%s' from %s:@." result.name (Option.value ~default:"verse" result.from_handle);
1635
+
Fmt.pr " Source: %s@." result.source_url;
1636
+
Option.iter (fun u -> Fmt.pr " Upstream: %s@." u) result.upstream_url;
1637
+
Fmt.pr " Packages: %a@." Fmt.(list ~sep:(any ", ") string) result.packages_added
1638
+
end else begin
1639
+
Fmt.pr "%a@." Monopam.Fork_join.pp_join_result result;
1640
+
Fmt.pr "@.Next steps:@.";
1641
+
Fmt.pr " 1. Commit the opam changes: cd opam-repo && git add -A && git commit@.";
1642
+
Fmt.pr " 2. Run $(b,monopam sync) to synchronize@."
1643
+
end;
1644
+
`Ok ()
1645
+
| Error e ->
1646
+
Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e;
1647
+
`Error (false, "join failed"))
1648
+
| None ->
1649
+
(* Normal join from URL - use --url if provided, otherwise positional arg *)
1650
+
let url = match fork_url with Some u -> u | None -> url_or_pkg in
1651
+
let name = match fork_url with Some _ -> Some url_or_pkg | None -> as_name in
1652
+
match Monopam.Fork_join.join ~proc ~fs ~config ~url ?name ?upstream ~dry_run () with
1653
+
| Ok result ->
1654
+
if dry_run then begin
1655
+
Fmt.pr "Would join '%s':@." result.name;
1656
+
Fmt.pr " Source: %s@." result.source_url;
1657
+
Option.iter (fun u -> Fmt.pr " Upstream: %s@." u) result.upstream_url;
1658
+
Fmt.pr " Packages: %a@." Fmt.(list ~sep:(any ", ") string) result.packages_added
1659
+
end else begin
1660
+
Fmt.pr "%a@." Monopam.Fork_join.pp_join_result result;
1661
+
Fmt.pr "@.Next steps:@.";
1662
+
Fmt.pr " 1. Run $(b,monopam sync) to synchronize@."
1663
+
end;
1664
+
`Ok ()
1665
+
| Error e ->
1666
+
Fmt.epr "Error: %a@." Monopam.Fork_join.pp_error_with_hint e;
1667
+
`Error (false, "join failed")
1668
+
in
1669
+
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))
1670
+
1462
1671
(* Main command group *)
1463
1672
1464
1673
let main_cmd =
···
1561
1770
in
1562
1771
let info = Cmd.info "monopam" ~version:"%%VERSION%%" ~doc ~man in
1563
1772
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 ]
1773
+
[ 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
1774
1566
1775
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";
+289
lib/fork_join.ml
+289
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
+
(** Normalize URL to git+ format for dev-repo *)
111
+
let normalize_git_url url =
112
+
if String.starts_with ~prefix:"git+" url then url
113
+
else if String.starts_with ~prefix:"git://" url then url
114
+
else if String.starts_with ~prefix:"https://" url then "git+" ^ url
115
+
else if String.starts_with ~prefix:"http://" url then "git+" ^ url
116
+
else url
117
+
118
+
(** Extract name from URL (last path component without .git suffix) *)
119
+
let name_from_url url =
120
+
let uri = Uri.of_string url in
121
+
let path = Uri.path uri in
122
+
(* Remove leading slash and .git suffix *)
123
+
let path = if String.length path > 0 && path.[0] = '/' then
124
+
String.sub path 1 (String.length path - 1)
125
+
else path in
126
+
let path = if String.ends_with ~suffix:".git" path then
127
+
String.sub path 0 (String.length path - 4)
128
+
else path in
129
+
(* Get last component *)
130
+
match String.rindex_opt path '/' with
131
+
| Some i -> String.sub path (i + 1) (String.length path - i - 1)
132
+
| None -> path
133
+
134
+
let fork ~proc ~fs ~config ~name ?push_url ?(dry_run = false) () =
135
+
let monorepo = Verse_config.mono_path config in
136
+
let checkouts = Verse_config.src_path config in
137
+
let prefix = name in
138
+
let subtree_path = Fpath.(monorepo / prefix) in
139
+
let src_path = Fpath.(checkouts / name) in
140
+
(* Validate: mono/<name>/ must exist *)
141
+
if not (Git.Subtree.exists ~fs ~repo:monorepo ~prefix) then
142
+
Error (Subtree_not_found name)
143
+
(* Validate: src/<name>/ must not exist *)
144
+
else if is_directory ~fs src_path then
145
+
Error (Src_already_exists name)
146
+
else begin
147
+
(* Find .opam files in subtree *)
148
+
let packages = find_opam_files ~fs subtree_path in
149
+
if packages = [] then
150
+
Error (No_opam_files name)
151
+
else if dry_run then
152
+
Ok { name; split_commit = "(dry-run)"; src_path; push_url; packages_created = packages }
153
+
else begin
154
+
(* Split the subtree to get history *)
155
+
match Git.Subtree.split ~proc ~fs ~repo:monorepo ~prefix () with
156
+
| Error e -> Error (Git_error e)
157
+
| Ok split_commit ->
158
+
(* Ensure src/ exists *)
159
+
ensure_dir ~fs checkouts;
160
+
(* Initialize new git repo at src/<name>/ *)
161
+
match Git.init ~proc ~fs src_path with
162
+
| Error e -> Error (Git_error e)
163
+
| Ok () ->
164
+
(* Add 'origin' remote pointing to monorepo path temporarily *)
165
+
let mono_str = Fpath.to_string monorepo in
166
+
(match Git.add_remote ~proc ~fs ~name:"mono" ~url:mono_str src_path with
167
+
| Error e -> Error (Git_error e)
168
+
| Ok () ->
169
+
(* Push split commit to local repo *)
170
+
let ref_spec = split_commit ^ ":refs/heads/main" in
171
+
match Git.push_ref ~proc ~fs ~repo:monorepo ~target:(Fpath.to_string src_path) ~ref_spec () with
172
+
| Error e -> Error (Git_error e)
173
+
| Ok () ->
174
+
(* Checkout main branch *)
175
+
(match Git.checkout ~proc ~fs ~branch:"main" src_path with
176
+
| Error e -> Error (Git_error e)
177
+
| Ok () ->
178
+
(* Set push URL if provided *)
179
+
let push_result =
180
+
match push_url with
181
+
| Some url ->
182
+
(match Git.add_remote ~proc ~fs ~name:"origin" ~url src_path with
183
+
| Error e -> Error (Git_error e)
184
+
| Ok () -> Ok ())
185
+
| None -> Ok ()
186
+
in
187
+
match push_result with
188
+
| Error _ as e -> e
189
+
| Ok () ->
190
+
(* Only update sources.toml if there's a push URL *)
191
+
(match push_url with
192
+
| Some url ->
193
+
let sources_path = Fpath.(monorepo / "sources.toml") in
194
+
let sources =
195
+
match Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path with
196
+
| Ok s -> s
197
+
| Error _ -> Sources_registry.empty
198
+
in
199
+
let entry = Sources_registry.{
200
+
url = normalize_git_url url;
201
+
upstream = None;
202
+
branch = Some "main";
203
+
reason = None;
204
+
origin = Some Fork;
205
+
} in
206
+
let sources = Sources_registry.add sources ~subtree:name entry in
207
+
(match Sources_registry.save ~fs:(fs :> _ Eio.Path.t) sources_path sources with
208
+
| Ok () -> ()
209
+
| Error msg -> Logs.warn (fun m -> m "Failed to update sources.toml: %s" msg))
210
+
| None -> ());
211
+
Ok { name; split_commit; src_path; push_url; packages_created = packages }))
212
+
end
213
+
end
214
+
215
+
let join ~proc ~fs ~config ~url ?name ?upstream ?(dry_run = false) () =
216
+
let name = match name with Some n -> n | None -> name_from_url url in
217
+
let monorepo = Verse_config.mono_path config in
218
+
let checkouts = Verse_config.src_path config in
219
+
let prefix = name in
220
+
let subtree_path = Fpath.(monorepo / prefix) in
221
+
let src_path = Fpath.(checkouts / name) in
222
+
(* Validate: mono/<name>/ must not exist *)
223
+
if Git.Subtree.exists ~fs ~repo:monorepo ~prefix then
224
+
Error (Subtree_already_exists name)
225
+
else if dry_run then
226
+
Ok { name; source_url = url; upstream_url = upstream; packages_added = []; from_handle = None }
227
+
else begin
228
+
(* Ensure src/ exists *)
229
+
ensure_dir ~fs checkouts;
230
+
(* Clone to src/<name>/ *)
231
+
let branch = Verse_config.default_branch in
232
+
let uri = Uri.of_string url in
233
+
match Git.clone ~proc ~fs ~url:uri ~branch src_path with
234
+
| Error e -> Error (Git_error e)
235
+
| Ok () ->
236
+
(* Add subtree to monorepo *)
237
+
match Git.Subtree.add ~proc ~fs ~repo:monorepo ~prefix ~url:uri ~branch () with
238
+
| Error e -> Error (Git_error e)
239
+
| Ok () ->
240
+
(* Find .opam files in the new subtree *)
241
+
let packages = find_opam_files ~fs subtree_path in
242
+
(* Only update sources.toml if there's an upstream to track *)
243
+
(match upstream with
244
+
| Some _ ->
245
+
let sources_path = Fpath.(monorepo / "sources.toml") in
246
+
let sources =
247
+
match Sources_registry.load ~fs:(fs :> _ Eio.Path.t) sources_path with
248
+
| Ok s -> s
249
+
| Error _ -> Sources_registry.empty
250
+
in
251
+
let entry = Sources_registry.{
252
+
url = normalize_git_url url;
253
+
upstream = Option.map normalize_git_url upstream;
254
+
branch = Some branch;
255
+
reason = None;
256
+
origin = Some Join;
257
+
} in
258
+
let sources = Sources_registry.add sources ~subtree:name entry in
259
+
(match Sources_registry.save ~fs:(fs :> _ Eio.Path.t) sources_path sources with
260
+
| Ok () -> ()
261
+
| Error msg -> Logs.warn (fun m -> m "Failed to update sources.toml: %s" msg))
262
+
| None -> ());
263
+
Ok { name; source_url = url; upstream_url = upstream; packages_added = packages; from_handle = None }
264
+
end
265
+
266
+
let join_from_verse ~proc ~fs ~config ~verse_config ~package ~handle ~fork_url ?(dry_run = false) () =
267
+
(* First use verse fork to set up the opam entries *)
268
+
match Verse.fork ~proc ~fs ~config:verse_config ~handle ~package ~fork_url ~dry_run () with
269
+
| Error e -> Error (Verse_error e)
270
+
| Ok fork_result ->
271
+
if dry_run then
272
+
Ok {
273
+
name = fork_result.subtree_name;
274
+
source_url = fork_url;
275
+
upstream_url = Some fork_result.upstream_url;
276
+
packages_added = fork_result.packages_forked;
277
+
from_handle = Some handle;
278
+
}
279
+
else begin
280
+
(* Now join the repository *)
281
+
let name = fork_result.subtree_name in
282
+
match join ~proc ~fs ~config ~url:fork_url ~name ~upstream:fork_result.upstream_url ~dry_run () with
283
+
| Error e -> Error e
284
+
| Ok join_result ->
285
+
Ok { join_result with
286
+
packages_added = fork_result.packages_forked;
287
+
from_handle = Some handle;
288
+
}
289
+
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. *)