forked from
anil.recoil.org/monopam
Monorepo management for opam overlays
monopam: refactor pull.ml run into helpers (merlint E005)
+95
-100
+95
-100
lib/pull.ml
+95
-100
lib/pull.ml
···
492
492
conflicts;
493
493
(List.rev !unresolved, !applied)
494
494
495
+
(** Check whether any checkout or monorepo prefix is dirty. Returns
496
+
[Ok ()] when clean, [Error (Dirty_state _)] otherwise. *)
497
+
let check_dirty ~sw ~fs_t ~config pkgs =
498
+
Log.info (fun m -> m "Checking status of %d packages" (List.length pkgs));
499
+
let statuses = Status.compute_all ~sw ~fs:fs_t ~config pkgs in
500
+
let dirty_checkouts =
501
+
List.filter Status.has_local_changes statuses
502
+
|> List.map (fun s -> s.Status.package)
503
+
in
504
+
let monorepo = Config.Paths.monorepo config in
505
+
let mono_repo = Git.Repository.open_repo ~sw ~fs:fs_t monorepo in
506
+
let dirty_in_mono =
507
+
if Git.Repository.is_dirty mono_repo then
508
+
List.filter
509
+
(fun pkg ->
510
+
let prefix = Package.subtree_prefix pkg in
511
+
Ctx.is_directory ~fs:fs_t Fpath.(monorepo / prefix))
512
+
pkgs
513
+
else []
514
+
in
515
+
let dirty = dirty_checkouts @ dirty_in_mono in
516
+
if dirty <> [] then Error (Ctx.Dirty_state dirty) else Ok ()
517
+
518
+
(** Collect outer conflict records from pull results and attempt auto-resolution
519
+
if enabled. Returns the list of unresolved conflict paths. *)
520
+
let resolve_conflicts ~sw ~fs_t ~config ~auto ~inner_conflict_paths results =
521
+
let outer_conflict_records =
522
+
List.concat_map
523
+
(fun r ->
524
+
List.map
525
+
(fun (c : Git.Merge.conflict) ->
526
+
( r.repo_name ^ "/" ^ c.path,
527
+
{ c with path = r.repo_name ^ "/" ^ c.path } ))
528
+
r.conflicts)
529
+
results
530
+
in
531
+
let outer_conflicts = List.map fst outer_conflict_records in
532
+
let all_conflicts = inner_conflict_paths @ outer_conflicts in
533
+
match auto with
534
+
| None -> all_conflicts
535
+
| Some auto_opts ->
536
+
let monorepo = Config.Paths.monorepo config in
537
+
let conflict_records = List.map snd outer_conflict_records in
538
+
let unresolved, applied =
539
+
auto_resolve_conflicts ~sw ~fs:fs_t ~monorepo ~auto:auto_opts
540
+
conflict_records
541
+
in
542
+
if applied > 0 then
543
+
Log.app (fun m ->
544
+
m " ✓ auto-resolved %d conflict%s" applied
545
+
(if applied = 1 then "" else "s"));
546
+
inner_conflict_paths @ unresolved
547
+
548
+
(** Write post-pull metadata files or return a conflict error. *)
549
+
let finalize_pull ~proc ~fs_t ~config ~all_pkgs unresolved =
550
+
if unresolved = [] then begin
551
+
Init.write_readme ~proc ~fs:fs_t ~config all_pkgs;
552
+
Init.write_claude_md ~proc ~fs:fs_t ~config;
553
+
Init.write_dune_project ~proc ~fs:fs_t ~config all_pkgs;
554
+
Ok ()
555
+
end
556
+
else
557
+
Error
558
+
(Ctx.Pull_conflict
559
+
{
560
+
paths = unresolved;
561
+
hint =
562
+
"Edit the conflicted files under mono/, stage the resolution \
563
+
with 'git add', 'git commit', and run 'monopam push' again.";
564
+
})
565
+
566
+
(** Load sources.toml for the monorepo, returning [None] for legacy
567
+
workspaces without one. *)
568
+
let load_sources ~fs_t ~config =
569
+
let monorepo = Config.Paths.monorepo config in
570
+
let sources_path = Fpath.(monorepo / "sources.toml") in
571
+
match Sources_registry.load ~fs:(fs_t :> _ Eio.Path.t) sources_path with
572
+
| Ok s -> Some s
573
+
| Error _ -> None
574
+
495
575
let run ~sw ~proc ~fs ~config ?(packages = []) ?opam_repo_url ?auto () =
496
576
let ( let* ) = Result.bind in
497
577
let fs_t = Ctx.fs_typed fs in
···
510
590
in
511
591
if pkgs = [] && packages <> [] then
512
592
Error (Ctx.Package_not_found (List.hd packages))
513
-
else begin
514
-
Log.info (fun m -> m "Checking status of %d packages" (List.length pkgs));
515
-
let statuses = Status.compute_all ~sw ~fs:fs_t ~config pkgs in
516
-
let dirty_checkouts =
517
-
List.filter Status.has_local_changes statuses
518
-
|> List.map (fun s -> s.Status.package)
593
+
else
594
+
let* () = check_dirty ~sw ~fs_t ~config pkgs in
595
+
let inner_conflict_paths = mono_entries ~sw ~proc ~fs ~config in
596
+
let sources = load_sources ~fs_t ~config in
597
+
let repos = Ctx.unique_repos pkgs in
598
+
Log.info (fun m ->
599
+
m "Cloning/fetching %d unique repositories" (List.length repos));
600
+
let* checkout_results = clone_repos ~sw ~proc ~fs:fs_t ~config repos in
601
+
Log.info (fun m -> m "Processing %d unique subtrees" (List.length repos));
602
+
let* results =
603
+
process_subtrees ~sw ~proc ~fs ~config ?sources repos checkout_results
519
604
in
520
-
(* Refuse to pull when the mono itself has uncommitted changes that
521
-
overlap any package's prefix. Pull writes the merged tree back to
522
-
the working directory, which would silently overwrite WIP edits. *)
523
-
let monorepo = Config.Paths.monorepo config in
524
-
let mono_repo = Git.Repository.open_repo ~sw ~fs:fs_t monorepo in
525
-
let dirty_in_mono =
526
-
if Git.Repository.is_dirty mono_repo then
527
-
List.filter
528
-
(fun pkg ->
529
-
let prefix = Package.subtree_prefix pkg in
530
-
Ctx.is_directory ~fs:fs_t Fpath.(monorepo / prefix))
531
-
pkgs
532
-
else []
605
+
log_pull_results results;
606
+
let unresolved =
607
+
resolve_conflicts ~sw ~fs_t ~config ~auto ~inner_conflict_paths results
533
608
in
534
-
let dirty = dirty_checkouts @ dirty_in_mono in
535
-
if dirty <> [] then Error (Ctx.Dirty_state dirty)
536
-
else begin
537
-
(* Pull mono inner subtrees first (depth-first); collect any
538
-
conflicts from the inner merges so they're reported alongside
539
-
outer conflicts at the end. *)
540
-
let inner_conflict_paths = mono_entries ~sw ~proc ~fs ~config in
541
-
(* Load sources.toml so [subtree] can honor per-entry [path]
542
-
overrides. For legacy workspaces without sources.toml the
543
-
load returns an empty registry; the path field is always
544
-
[None] in that case, which matches today's whole-repo
545
-
behaviour. *)
546
-
let sources =
547
-
let monorepo = Config.Paths.monorepo config in
548
-
let sources_path = Fpath.(monorepo / "sources.toml") in
549
-
match Sources_registry.load ~fs:(fs_t :> _ Eio.Path.t) sources_path with
550
-
| Ok s -> Some s
551
-
| Error _ -> None
552
-
in
553
-
let repos = Ctx.unique_repos pkgs in
554
-
Log.info (fun m ->
555
-
m "Cloning/fetching %d unique repositories" (List.length repos));
556
-
let* checkout_results = clone_repos ~sw ~proc ~fs:fs_t ~config repos in
557
-
Log.info (fun m -> m "Processing %d unique subtrees" (List.length repos));
558
-
let* results =
559
-
process_subtrees ~sw ~proc ~fs ~config ?sources repos checkout_results
560
-
in
561
-
log_pull_results results;
562
-
(* Collect conflicts BEFORE running Init.write_* so we can short
563
-
circuit cleanly. The write_* helpers spawn git commit
564
-
subprocesses whose output is interleaved with our logs;
565
-
leaving them out on the conflict path keeps stdout
566
-
deterministic for the user (and for cram tests grepping the
567
-
output). *)
568
-
let outer_conflict_records =
569
-
List.concat_map
570
-
(fun r ->
571
-
List.map
572
-
(fun (c : Git.Merge.conflict) ->
573
-
( r.repo_name ^ "/" ^ c.path,
574
-
{ c with path = r.repo_name ^ "/" ^ c.path } ))
575
-
r.conflicts)
576
-
results
577
-
in
578
-
let outer_conflicts = List.map fst outer_conflict_records in
579
-
let all_conflicts = inner_conflict_paths @ outer_conflicts in
580
-
(* If --auto is enabled, try to resolve content conflicts via the AI
581
-
resolver before deciding the final state. *)
582
-
let unresolved_after_auto =
583
-
match auto with
584
-
| None -> all_conflicts
585
-
| Some auto_opts ->
586
-
let monorepo = Config.Paths.monorepo config in
587
-
let conflict_records = List.map snd outer_conflict_records in
588
-
let unresolved, applied =
589
-
auto_resolve_conflicts ~sw ~fs:fs_t ~monorepo ~auto:auto_opts
590
-
conflict_records
591
-
in
592
-
if applied > 0 then
593
-
Log.app (fun m ->
594
-
m " ✓ auto-resolved %d conflict%s" applied
595
-
(if applied = 1 then "" else "s"));
596
-
inner_conflict_paths @ unresolved
597
-
in
598
-
if unresolved_after_auto = [] then begin
599
-
Init.write_readme ~proc ~fs:fs_t ~config all_pkgs;
600
-
Init.write_claude_md ~proc ~fs:fs_t ~config;
601
-
Init.write_dune_project ~proc ~fs:fs_t ~config all_pkgs
602
-
end;
603
-
if unresolved_after_auto <> [] then
604
-
Error
605
-
(Ctx.Pull_conflict
606
-
{
607
-
paths = unresolved_after_auto;
608
-
hint =
609
-
"Edit the conflicted files under mono/, stage the resolution \
610
-
with 'git add', 'git commit', and run 'monopam push' again.";
611
-
})
612
-
else Ok ()
613
-
end
614
-
end
609
+
finalize_pull ~proc ~fs_t ~config ~all_pkgs unresolved